Clean up the code

Removed unwanted diffs introduced by a series of modifications

frege/compiler/Classes.fr

@@ -243,7 +243,7 @@ passC = do
                 [osym] | Just (SymbolT.V ali) <- g.findit msym.alias,
                          ali.anno,
                          -- symc.name == same,
-                         Just (SymbolT.C ssym) <- g.findit osym.name.tynm = do
+                         Just (SymbolT.C ssym) <- g.findit osym.name.tynm -> do
                                     sig <- mkanno symc msym.pos osym ssym
                                     T.subsCheck (SymbolT.V ali) ali.typ sig
                        | otherwise = E.error pos (msgdoc (nicer msym g 
@@ -402,7 +402,7 @@ instForClass alien c iname = do
 
                 csyms <- mapSt U.findC (csym.name:csym.supers)
                 isym  <- U.findI isym.name
-                when (not alien || g.our isym.name) do tcInstMethods csyms  isym
+                when (not alien || g.our isym.name) do tcInstMethods csyms isym
             Nothing -> E.fatal isym.pos (text ("instForClass: bad instance type " ++ isym.typ.nice g))
 
 {--
@@ -579,7 +579,7 @@ funForCIT cname iname tname (mname@MName _ base) = do
                         linkq (MName tname base) $ SymbolT.V ivsym
                         changeSym $ SymbolT.V ivsym.{op=msym.op}  -- copy op
                 | otherwise = E.error isym.pos (msgdoc ("implementation missing for " ++ ivsym.nice g))
-            Just (SymMeth.L SymL{pos=ipos, name=member, alias})    -- imported instance with links to type methods? 
+            Just (SymMeth.L SymL{pos=ipos, name=member, alias})    -- imported instance with links to type methods?
                 | not (g.our iname), alias.{tynm?}, alias.tynm == tname = stio ()
                 | otherwise = case g.findit alias of
                     Just symv' | SymbolT.V symv <- symv', not symv.anno && not (maybe false (const true) symv.nativ) = do

frege/compiler/Kinds.fr

@@ -89,10 +89,10 @@ kiTypeSym names sym = do
     g <- getST
     E.logmsg TRACEK sym.pos (text ("kind check for " ++ nice sym g))
     -- kind check all constructor sigmas
-    let cons = [ con | SymbolT.D con <- values $ sym.env ]
+    let cons = [ con | SymbolT.D con <- values sym.env ]
     foreach cons (kiConSym names)
     g ← getST
-    sym <- U.findT $ sym.name
+    sym <- U.findT sym.name
     let kflat (KApp k ks) = k : kflat ks
         kflat ks          = [ks]
         typ = ForAll (zipWith Tau.{kind=} (sym.typ.bound) (kflat sym.kind)) sym.typ.rho

frege/compiler/Typecheck.fr

@@ -425,7 +425,7 @@ resolveConstraints sym
         x   <- x >>= resolveHas 
         cxs <- collectConstrs x
         rho <- simplify symv.pos typ.rho.{context=cxs}
-                >>= simplify symv.pos        -- remove duplicates 
+                >>= simplify symv.pos        -- remove duplicates
         -- Drop the contexts that contain a rigid tvar that is not occurring in the type itself.
         -- Those stem from typechecking applications of higher rank functions where
         -- there is a constraint in an inner forall.
@@ -436,7 +436,7 @@ resolveConstraints sym
             ctxmetas = map (ctxTvs g) rho.context
         let filteredCtx = [ ctx | (metas, ctx) <- zip ctxmetas rho.context,
                                   all (`elem` rhometas)  (filter (not . MetaTv.isFlexi) metas)]
-        changeSym $ SymbolT.V symv.{typ <- Sigma.{rho <- rmtrailing . Rho.{context=filteredCtx}}, 
+        changeSym $ SymbolT.V symv.{typ <- Sigma.{rho <- rmtrailing . Rho.{context=filteredCtx}},
                          expr = Just (return x)}
     | otherwise = return ()
     where 
@@ -942,9 +942,9 @@ tcRho' (x@Vbl {name})  ety = do
     case sym of
         SymVal.D _ -> tcRho' Con{pos=x.pos, name=x.name, typ=x.typ} ety
         SymVal.V symv -> case isPSigma symv.typ of
-            false -> if symv.state != Typechecked 
+            false -> if symv.state != Typechecked
                     then do
-                        sig ← fst <$> K.kiSigma [] [] symv.typ
+                        sig <- fst <$> K.kiSigma [] [] symv.typ
                         changeSym $ SymbolT.V symv.{typ=sig}
                         rho <- instantiate sig
                         instRho x rho ety 
@@ -1110,10 +1110,10 @@ tcRho' (x@Mem {ex,member}) ety = do
                       TCon{name=tcon}:_ <- ntau.flat,
                       Just (SymbolT.T SymT{nativ=Just s}) <- g.findit tcon,
                       (SymbolT.V SymV{name=m}):_ <-
-                        [ h
-                        | sup <- s:U.supersOfNativ s g
-                        , q <- U.typesOfNativ sup g
-                        , h <- g.findit (MName q member.value) ]
+                          [ h
+                          | sup <- s:U.supersOfNativ s g
+                          , q <- U.typesOfNativ sup g
+                          , h <- g.findit (MName q member.value) ]
                       = do
                             changeST Global.{sub <- SubSt.{
                                 idKind <- insert (KeyTk original) (Right m)}}
@@ -1427,7 +1427,7 @@ rHas flagerr (v@Vbl{pos, name, typ}) | not name.isLocal = do
                         return (Right v)
                     ms:_ -> case sortBy (comparing arityV) ms of                    -- compare b arity to find
                                                                                     --       the one that fits
-                        cs -> case filter ((arityV (head cs) ==) . arityV) cs of      -- remove the ones that don't
+                        cs -> case filter ((arityV (head cs) ==) . arityV) cs of    -- remove the ones that don't
                             some -> do
                                 when (length some > 1) do
                                     E.warn v.pos (text "overloaded `" <> text (nicer v g) 
@@ -1465,15 +1465,15 @@ rHas flagerr (v@Vbl{pos, name, typ}) | not name.isLocal = do
                 overloads :: Global -> SymV Global -> [SymV Global]
                 overloads g sym = case sym of
                     SymV{over=[]} -> [sym]
-                    SymV{name = MName{tynm, base}, over=over@(_:_)}
+                    SymV{name = MName{tynm, base}, over=(_:_)}
                         | Just (SymbolT.T SymT{nativ = Just this}) <- g.findit tynm,
-                          ov <- [ sy | m <- over, SymbolT.V sy <- g.findit m ],
+                          ov <- [ sy | m <- sym.over, SymbolT.V sy <- g.findit m ],
                           syms <- [ sy | s  <- U.supersOfNativ this g, 
                                          q  <- U.typesOfNativ s g, 
                                          SymbolT.V h <- g.findit (MName q base),
                                          sy <- overloads g h] 
                         = ov++syms
-                    SymV{over} -> [ sy | m <- over, SymbolT.V sy <- g.findit m ]
+                    SymV{} -> [ sy | m <- sym.over, SymbolT.V sy <- g.findit m ]
                 arityV = arity . SymVal.V
 
 rHas _ x = pure (Left x)             

frege/compiler/Utilities.fr

@@ -232,7 +232,7 @@ freeTauTVars _ collected _ = collected
 
 --- return a list of constructors in this environment ordered by constructor number
 envConstructors :: Symtab -> [SymD Global]
-envConstructors env = sortBy (comparing SymD.cid) [ syd | SymbolT.D syd <- values env ]
+envConstructors env = sortBy (comparing _.cid) [ syd | SymbolT.D syd <- values env ]
 
 
 --- provide a new Position for a Pattern
@@ -702,7 +702,7 @@ foldEx b f a ex = do
                 Let {env,ex}
                     | b = do
                         syms <- mapSt findV env
-                        xs <- sequence [ x | SymV{expr=Just x} <- syms ]
+                        xs <- sequence [ x | SymV {expr=Just x} <- syms ]
                         a <- foldSt (foldEx b f) a xs
                         foldEx b f a ex
                     | otherwise = foldEx b f a ex
@@ -749,7 +749,7 @@ mapEx b f x = do
             Let {env,ex,typ}
                 | b = do
                     syms <- mapSt findV env
-                    let xs = [ sy | sy@SymV{expr=Just _} <- syms ]
+                    let xs = [ sy | sy@SymV {expr=Just _} <- syms ]
                     foreach xs mapsub
                     ex  <- mapEx b f ex
                     stio (Let {env,ex,typ})
@@ -942,7 +942,7 @@ fundep (SymV{name, expr=Just dx})  = do
     g <- getST
     x <- dx 
     deptree <- ourGlobalFuns empty x
-    let dep = [ name | sy <- keys deptree, let name = sy.name, g.our name ]
+    let dep = [ sy.name | sy <- keys deptree, g.our sy.name ]
     stio (name, dep)
 fundep (SymV{name, expr=Nothing}) = stio (name, [])
 

frege/compiler/common/Lens.fr

@@ -1,8 +1,10 @@
---- The code here is taken and modified from Haskell's "lens" packages.
----
---- lens:
---- Copyright 2012-2016 Edward Kmett
---- License BSD-2-Clause
+{--
+   The code here is taken and modified from Haskell's "lens" packages.
+
+   lens:
+   Copyright 2012-2016 Edward Kmett
+   License BSD-2-Clause
+ -}
 module frege.compiler.common.Lens where
 
 import  frege.data.Monoid (First)
@@ -12,6 +14,7 @@ import  frege.data.wrapper.Identity (Identity)
 
 -- note: currently the compiler fails to infer the correct kinds of @f@
 -- when incrementally compiling, so you have to write type annotations without the aliases
+-- see GutHub issue #383
 
 type ASetter s t a b = (a -> Identity b) -> s -> Identity t
 type ASetter' s a = ASetter s s a a
@@ -73,8 +76,3 @@ _Just _ Nothing = pure Nothing
 _Nothing :: Traversal' (Maybe a) ()
 _Nothing _ Nothing = pure Nothing
 _Nothing _ (Just x) = pure (Just x)
-
---- warning: this function is partial
--- TODO eliminate the uses of these functions
-unsafePartialView :: Getting (First a) s a -> s -> a
-unsafePartialView l s = unJust $ preview l s

frege/compiler/common/SymbolTable.fr

@@ -53,11 +53,11 @@ private insertSym toSymbol tab key value = case tab.lookupS key of
         let on = (toSymbol old).nice g
             qn = (toSymbol value).nice g
         case toSymbol value of
-            SymbolT.V SymV{pos, name} -> E.error pos (msgdoc("duplicate function or pattern binding for `"
+            SymbolT.V SymV{pos, name} -> E.error pos $ msgdoc $ "duplicate function or pattern binding for `"
                             ++ name.nice g ++ "`, already bound on line "
-                            ++ show (toSymbol old).pos))
-            _          -> E.error (toSymbol value).pos (msgdoc("redefinition of " ++ on ++ " with " ++ qn
-                                    ++ " introduced on line " ++ show (toSymbol old).pos))
+                            ++ show (toSymbol old).pos
+            _          -> E.error (toSymbol value).pos $ msgdoc $ "redefinition of " ++ on ++ " with " ++ qn
+                                    ++ " introduced on line " ++ show (toSymbol old).pos
         stio (tab.insertS key value)
 
 
@@ -72,9 +72,9 @@ private updateSym toSymbol tab key value = case tab.lookupS key of
         stio (tab.insert key value)
 
 {--
- - Assume a Symbol is SymV because it's name is Local
- -
- - It is caller's responsibility to ensure that.
+   Assume a Symbol is SymV because it's name is Local
+
+   It is caller's responsibility to ensure that.
  -}
 private toSymVBecauseLocal :: Symbol -> SymV Global
 private toSymVBecauseLocal (SymbolT.V symv) = symv
@@ -112,7 +112,7 @@ enter sym = case sym of
                 let symv = toSymVBecauseLocal sym
                 case g.find sym.name of
                     Nothing
-                        | uid == symv.sid-> do
+                        | uid == symv.sid -> do
                             E.logmsg TRACE3 symv.pos (text("enterLocal: " ++
                                 show symv.sid ++
                                 " " ++ sym.nice g ++ " :: " ++ symv.typ.nice g ++

frege/compiler/common/Trans.fr

@@ -290,7 +290,7 @@ patsComplete g ps
                     Just (SymbolT.T (SymT {env})) -> U.envConstructors env
                     _ -> []
                 cons _ = []
-                mkCon (SymD{name,flds}) = PCon {pos=Position.null, qname=name,
+                mkCon (SymD {name,flds}) = PCon {pos=Position.null, qname=name,
                                                     pats = map (const pany) flds}
                 group :: [Pattern] -> [(QName, [[Pattern]])]
                 group [] = []

frege/compiler/gen/java/Common.fr

@@ -608,7 +608,7 @@ symInfo sym = do
                     </> text "si.retSig  " <+> text (nice si.retSig g)
                     -- </> text "
                     )
-                zipWithM_ (\s j → E.logmsg TRACEG symv.pos (
+                zipWithM_ (\s j -> E.logmsg TRACEG symv.pos (
                     text "arg :: " <+> text (nicer s g) <+> text " @@ " <+> text (show j)
                     )) si.argSigs si.argJTs
                 return si

frege/compiler/gen/java/DataCode.fr

@@ -336,4 +336,4 @@ subDecls sym = do
     g ← getST
     E.logmsg TRACEG sym.pos (text ("subDecls for " ++ nicer sym g))
     let subdefs = mapMaybe SymMeth.fromSymbol (values sym.env)   -- no constructors
-    concat <$> mapM (varCode emptyTree) subdefs 
+    concat <$> mapM (varCode emptyTree) subdefs 

frege/compiler/gen/java/InstanceCode.fr

@@ -382,7 +382,7 @@ instFun symc symi mname = do
                         </> text (nicer cmem.name g) <+> text " :: " <+> text (nicer cmem.typ g)
                     )
                 let otvs = filter ((`elem` symi.typ.vars) . Tau.var) cmem.typ.tvars
-                    orep = filter (`notElem` cmem.typ.vars) (allBinders g)
+                    orep = filter (`notElem` (cmem.typ.vars)) (allBinders g)
                     substBound :: TreeMap String Tau -> [Tau] -> [Tau]
                     substBound subst xs = map (\tv -> maybe tv _.{kind=tv.kind} (lookup tv.var subst)) xs
                     subst1 = Map.fromList [ (tv.var, tv.{var=s}) | (s,tv) ← zip orep otvs]

frege/compiler/gen/java/Match.fr

@@ -168,9 +168,9 @@ match assert (pat@PCon {pos,qname,pats}) bind  cont binds = do
          if symt.enum then matchEnum symd
              else if symt.product
                  then if symt.newt
-                     then matchNew symd symt
-                     else matchProd symd symt  -- pat bind cont binds
-                 else matchVariant symd symt   -- pat bind cont binds
+                     then matchNew     symd symt
+                     else matchProd    symd symt -- pat bind cont binds
+                 else matchVariant symd symt -- pat bind cont binds
      where
          unKindedStrict g lbnd = case strictBind g lbnd of
                     kbnd ->  case kbnd.jtype of

frege/compiler/gen/java/MethodCall.fr

@@ -157,7 +157,7 @@ nativeCall g sym subst aexs = error ("nativeCall: no function "
     ++ ", " ++ nicer sym g)
 
 wrapCode :: Global -> (JExpr -> JStmt) -> Tau -> SymV Global -> TreeMap String Tau -> [JExpr] -> [JStmt]
-wrapCode g jreturn rtau (sym@SymV{nativ = Just item, throwing}) subst aexs
+wrapCode g jreturn rtau (sym@SymV {nativ = Just item, throwing}) subst aexs
     | Just (stau, atau) <- unST rtau = let
             sjt     = tauJT g stau          -- type #1 for parameterization of ST s a
             ajt     = tauJT g atau          -- return type of the ST action
@@ -223,7 +223,7 @@ wrapCode g jreturn rtau (sym@SymV{nativ = Just item, throwing}) subst aexs
         catch rty = case tauJT g rty of
                         Nativ{typ, gargs} -> "catch (" ++ typ ++ " ex)"
                         other -> error ("bad exception type " ++ show other)        
-wrapCode _ _ _ _ _ _ = error "wrapCode: non-native SymV"
+wrapCode _ _ _ _ _ _ = error "wrapCode - no native function"
 
 
 {--
@@ -236,7 +236,7 @@ methCode g (symv@SymV {nativ = Just item}) si = [
         JComment ("the following type variables are probably wildcards: " ++ joined ", " (map _.var wildr)),
         JComment item] ++
                 (if arity then defs 
-                 else if wrapped g symv || niKind item != NIStatic 
+                 else if wrapped g symv || niKind item != NIStatic
                     then [member]
                     else [])
     where

frege/compiler/gen/java/VarCode.fr

@@ -61,7 +61,7 @@ import Compiler.gen.java.Instantiation(instPatternBound, resolveConstraint, envC
 import Compiler.gen.java.PrettyJava(lambda7, thunkMarker)
 
 varCode :: TreeMap Int Binding -> SymMeth Global -> StG [JDecl]
-varCode _ (SymMeth.L SymL{sid, pos, vis, name, alias})  = do
+varCode _ (SymMeth.L SymL{sid, pos, vis, name, alias}) = do
     g ← getST
     pure [JComment ("alias " 
             ++ name.base
@@ -79,7 +79,7 @@ varCode binds (SymMeth.V symv) = do
         SymV{nativ = Just _, over}
             | null over = do
                 g   ← getST
-                E.logmsg TRACEG symv.pos (text "native var:" 
+                E.logmsg TRACEG symv.pos (text "native var:"
                             <+> text (nice symv.name g) <+> text "∷"
                             <+> text (nicer symv.typ.rho g)
                             <>  text ", depth="  <> anno symv.depth
@@ -88,7 +88,7 @@ varCode binds (SymMeth.V symv) = do
                 return (comment : methCode g symv si)
             | otherwise = return []         -- there is no code for overloads
             where
-                comment = JComment (nicer symv g) 
+                comment = JComment (nicer symv g)
         _ -> error ("varCode: bad SymV " ++ nicer symv g)
 
 --- Generate code for a function with arguments
@@ -895,7 +895,7 @@ genLetEnvs jret rm before inclass after ex binds = do
          genLetClass binds []   = pure (binds, [])
          genLetClass binds syms = do
             g <- getST
-            forM syms (changeSym . SymbolT.V . _.{rkind ← (BitSet.`unionE` RMethod)})
+            forM syms (changeSym . SymbolT.V . _.{rkind <- (BitSet.`unionE` RMethod)})
             -- refresh the symbols
             syms <- mapM U.findV (map _.name syms)
             u <- uniqid
@@ -916,7 +916,7 @@ genLetEnvs jret rm before inclass after ex binds = do
             -- stmts <- genStmts jret rm ex letbinds
             pure (letbinds, [JLocal letcl, JLocal var])
 
-         mkbind :: Global -> (String -> JX)  -> TreeMap Int Binding -> SymV Global -> TreeMap Int Binding
+         mkbind :: Global -> (String -> JX) -> TreeMap Int Binding -> SymV Global -> TreeMap Int Binding
          mkbind g prefix binds sym = insert sym.sid bind binds 
             where
                 bind = Bind{stype=nicer sym.typ g, 

frege/compiler/passes/Easy.fr

@@ -102,7 +102,7 @@ easySym (vsym@SymV {pos})
 
 
 checkDepth :: SymMeth Global -> StG ()
-checkDepth (SymMeth.V (vsym@SymV {pos, name = MName inst  base})) = do
+checkDepth (SymMeth.V (vsym@SymV {pos, name = MName inst base})) = do
         g <- getST
         cmeth <- classMethodOfInstMethod pos inst base
         when (cmeth.depth > vsym.depth) do
@@ -113,7 +113,7 @@ checkDepth (SymMeth.V (vsym@SymV {pos, name = MName inst  base})) = do
         when (cmeth.depth < vsym.depth) do
             changeSym $ SymbolT.V vsym.{depth = cmeth.depth}
         return ()
-checkDepth (SymMeth.L (vsym@SymL {pos, alias, name = MName inst  base})) = do
+checkDepth (SymMeth.L (vsym@SymL {pos, alias, name = MName inst base})) = do
         g <- getST
         cmeth <- classMethodOfInstMethod pos inst base
         rmeth <- U.findVD alias
@@ -153,7 +153,7 @@ depthSym (vsym@SymV {pos})
                 g <- getST                                      -- depth < sigmas, eta expand it
                 newx <- etaExpand nx
                 let newd = U.lambdaDepth newx
-                E.logmsg TRACE9 vsym.pos (text ("eta expanded "
+                E.logmsg TRACE9 (vsym.pos) (text ("eta expanded "
                     ++ nice vsym.name g ++ "::" ++ nice typ g
                     ++ " to lambda depth " ++ show newd))
                 E.logmsg TRACE9 vsym.pos (text ("old expr: " ++ nice nx   g ++ " :: "