591556a · Idris-dev · git.iko.soy

git.iko.soy/Idris-dev

on master help sign in

Merge pull request #2250 from david-christiansen/name-highlights

591556aDavid Christiansen11 years ago

src/Idris/AbsSyntax.hs+111−109

compare with master

unifiedsplit

@@ -952,21 +952,21 @@ expandParams dec ps ns infs tm = en tm

952 mkShadow (MN i n) = MN (i+1) n

953 mkShadow (NS x s) = NS (mkShadow x) s

954

955− en (PLam fc n t s)

955+ en (PLam fc n nfc t s)

956 | n `elem` (map fst ps ++ ns)

957 = let n' = mkShadow n in

958− PLam fc n' (en t) (en (shadow n n' s))

958+ PLam fc n' nfc (en t) (en (shadow n n' s))

959− | otherwise = PLam fc n (en t) (en s)

959+ | otherwise = PLam fc n nfc (en t) (en s)

960− en (PPi p n t s)

960+ en (PPi p n nfc t s)

961 | n `elem` (map fst ps ++ ns)

962 = let n' = mkShadow n in -- TODO THINK SHADOWING TacImp?

963− PPi (enTacImp p) n' (en t) (en (shadow n n' s))

963+ PPi (enTacImp p) n' nfc (en t) (en (shadow n n' s))

964− | otherwise = PPi (enTacImp p) n (en t) (en s)

964+ | otherwise = PPi (enTacImp p) n nfc (en t) (en s)

965− en (PLet fc n ty v s)

965+ en (PLet fc n nfc ty v s)

966 | n `elem` (map fst ps ++ ns)

967 = let n' = mkShadow n in

968− PLet fc n' (en ty) (en v) (en (shadow n n' s))

968+ PLet fc n' nfc (en ty) (en v) (en (shadow n n' s))

969− | otherwise = PLet fc n (en ty) (en v) (en s)

969+ | otherwise = PLet fc n nfc (en ty) (en v) (en s)

970 -- FIXME: Should only do this in a type signature!

971 en (PDPair f p (PRef f' n) t r)

972 | n `elem` (map fst ps ++ ns) && t /= Placeholder

@@ -1027,12 +1027,12 @@ expandParams dec ps ns infs tm = en tm

1027expandParamsD :: Bool -> -- True = RHS only

1028 IState ->

1029 (Name -> Name) -> [(Name, PTerm)] -> [Name] -> PDecl -> PDecl

1030−expandParamsD rhsonly ist dec ps ns (PTy doc argdocs syn fc o n ty)

1030+expandParamsD rhsonly ist dec ps ns (PTy doc argdocs syn fc o n nfc ty)

1031 = if n `elem` ns && (not rhsonly)

1032 then -- trace (show (n, expandParams dec ps ns ty)) $

1033− PTy doc argdocs syn fc o (dec n) (piBindp expl_param ps (expandParams dec ps ns [] ty))

1033+ PTy doc argdocs syn fc o (dec n) nfc (piBindp expl_param ps (expandParams dec ps ns [] ty))

1034 else --trace (show (n, expandParams dec ps ns ty)) $

1035− PTy doc argdocs syn fc o n (expandParams dec ps ns [] ty)

1035+ PTy doc argdocs syn fc o n nfc (expandParams dec ps ns [] ty)

1036expandParamsD rhsonly ist dec ps ns (PPostulate e doc syn fc o n ty)

1037 = if n `elem` ns && (not rhsonly)

1038 then -- trace (show (n, expandParams dec ps ns ty)) $

@@ -1085,35 +1085,36 @@ expandParamsD rhs ist dec ps ns (PData doc argDocs syn fc co pd)

1085 where

1086 -- just do the type decl, leave constructors alone (parameters will be

1087 -- added implicitly)

1088− expandPData (PDatadecl n ty cons)

1088+ expandPData (PDatadecl n nfc ty cons)

1089 = if n `elem` ns

1090− then PDatadecl (dec n) (piBind ps (expandParams dec ps ns [] ty))

1090+ then PDatadecl (dec n) nfc (piBind ps (expandParams dec ps ns [] ty))

1091 (map econ cons)

1092− else PDatadecl n (expandParams dec ps ns [] ty) (map econ cons)

1092+ else PDatadecl n nfc (expandParams dec ps ns [] ty) (map econ cons)

1093− econ (doc, argDocs, n, t, fc, fs)

1093+ econ (doc, argDocs, n, nfc, t, fc, fs)

1094− = (doc, argDocs, dec n, piBindp expl ps (expandParams dec ps ns [] t), fc, fs)

1094+ = (doc, argDocs, dec n, nfc, piBindp expl ps (expandParams dec ps ns [] t), fc, fs)

1095−expandParamsD rhs ist dec ps ns d@(PRecord doc rsyn fc opts name prs pdocs fls cn cdoc csyn)

1095+expandParamsD rhs ist dec ps ns d@(PRecord doc rsyn fc opts name nfc prs pdocs fls cn cdoc csyn)

1096− = d

1096+ = d

1097expandParamsD rhs ist dec ps ns (PParams f params pds)

1098 = PParams f (ps ++ map (mapsnd (expandParams dec ps ns [])) params)

1099 (map (expandParamsD True ist dec ps ns) pds)

1100-- (map (expandParamsD ist dec ps ns) pds)

1101expandParamsD rhs ist dec ps ns (PMutual f pds)

1102 = PMutual f (map (expandParamsD rhs ist dec ps ns) pds)

1103−expandParamsD rhs ist dec ps ns (PClass doc info f cs n params pDocs fds decls cn cd)

1103+expandParamsD rhs ist dec ps ns (PClass doc info f cs n nfc params pDocs fds decls cn cd)

1104 = PClass doc info f

1105 (map (\ (n, t) -> (n, expandParams dec ps ns [] t)) cs)

1106− n

1106+ n nfc

1107− (map (mapsnd (expandParams dec ps ns [])) params)

1107+ (map (\(n, fc, t) -> (n, fc, expandParams dec ps ns [] t)) params)

1108 pDocs

1109 fds

1110 (map (expandParamsD rhs ist dec ps ns) decls)

1111 cn

1112 cd

1113−expandParamsD rhs ist dec ps ns (PInstance doc argDocs info f cs n params ty cn decls)

1113+expandParamsD rhs ist dec ps ns (PInstance doc argDocs info f cs n nfc params ty cn decls)

1114 = PInstance doc argDocs info f

1115 (map (\ (n, t) -> (n, expandParams dec ps ns [] t)) cs)

1116 n

1117+ nfc

1117 (map (expandParams dec ps ns []) params)

1118 (map (expandParams dec ps ns []) params)

1118 (expandParams dec ps ns [] ty)

1119 (expandParams dec ps ns [] ty)

1119 cn

1120 cn

@@ -1137,7 +1138,7 @@ getPriority i tm = 1 -- pri tm

1137 ((P (TCon _ _) _ _):_) -> 1

1138 ((P (TCon _ _) _ _):_) -> 1

1138 ((P Ref _ _):_) -> 1

1139 ((P Ref _ _):_) -> 1

1139 [] -> 0 -- must be locally bound, if it's not an error...

1140 [] -> 0 -- must be locally bound, if it's not an error...

1140− pri (PPi _ _ x y) = max 5 (max (pri x) (pri y))

1141+ pri (PPi _ _ _ x y) = max 5 (max (pri x) (pri y))

1141 pri (PTrue _ _) = 0

1142 pri (PTrue _ _) = 0

1142 pri (PRewrite _ l r _) = max 1 (max (pri l) (pri r))

1143 pri (PRewrite _ l r _) = max 1 (max (pri l) (pri r))

1143 pri (PApp _ f as) = max 1 (max (pri f) (foldr max 0 (map (pri.getTm) as)))

1144 pri (PApp _ f as) = max 1 (max (pri f) (foldr max 0 (map (pri.getTm) as)))

@@ -1147,7 +1148,7 @@ getPriority i tm = 1 -- pri tm

1147 pri (PPair _ _ l r) = max 1 (max (pri l) (pri r))

1148 pri (PPair _ _ l r) = max 1 (max (pri l) (pri r))

1148 pri (PDPair _ _ l t r) = max 1 (max (pri l) (max (pri t) (pri r)))

1149 pri (PDPair _ _ l t r) = max 1 (max (pri l) (max (pri t) (pri r)))

1149 pri (PAlternative a as) = maximum (map pri as)

1150 pri (PAlternative a as) = maximum (map pri as)

1150− pri (PConstant _) = 0

1151+ pri (PConstant _ _) = 0

1151 pri Placeholder = 1

1152 pri Placeholder = 1

1152 pri _ = 3

1153 pri _ = 3

1153

1154

@@ -1181,10 +1182,10 @@ addStatics n tm ptm =

1181 putIState $ i { idris_statics = addDef n stpos (idris_statics i) }

1182 putIState $ i { idris_statics = addDef n stpos (idris_statics i) }

1182 addIBC (IBCStatic n)

1183 addIBC (IBCStatic n)

1183 where

1184 where

1184− initStatics (Bind n (Pi _ ty _) sc) (PPi p n' t s)

1185+ initStatics (Bind n (Pi _ ty _) sc) (PPi p n' fc t s)

1185− | n /= n' = let (static, dynamic) = initStatics sc (PPi p n' t s) in

1186+ | n /= n' = let (static, dynamic) = initStatics sc (PPi p n' fc t s) in

1186 (static, (n, ty) : dynamic)

1187 (static, (n, ty) : dynamic)

1187− initStatics (Bind n (Pi _ ty _) sc) (PPi p n' _ s)

1188+ initStatics (Bind n (Pi _ ty _) sc) (PPi p n' fc _ s)

1188 = let (static, dynamic) = initStatics (instantiate (P Bound n ty) sc) s in

1189 = let (static, dynamic) = initStatics (instantiate (P Bound n ty) sc) s in

1189 if pstatic p == Static then ((n, ty) : static, dynamic)

1190 if pstatic p == Static then ((n, ty) : static, dynamic)

1190 else if (not (searchArg p))

1191 else if (not (searchArg p))

@@ -1253,16 +1254,16 @@ addUsingConstraints syn fc t

1253 -- if all of args in ns, then add it

1254 -- if all of args in ns, then add it

1254 doAdd (UConstraint c args : cs) ns t

1255 doAdd (UConstraint c args : cs) ns t

1255 | all (\n -> elem n ns) args

1256 | all (\n -> elem n ns) args

1256− = PPi (Constraint [] Dynamic) (sMN 0 "cu")

1257+ = PPi (Constraint [] Dynamic) (sMN 0 "cu") NoFC

1257 (mkConst c args) (doAdd cs ns t)

1258 (mkConst c args) (doAdd cs ns t)

1258 | otherwise = doAdd cs ns t

1259 | otherwise = doAdd cs ns t

1259

1260

1260 mkConst c args = PApp fc (PRef fc c)

1261 mkConst c args = PApp fc (PRef fc c)

1261 (map (\n -> PExp 0 [] (sMN 0 "carg") (PRef fc n)) args)

1262 (map (\n -> PExp 0 [] (sMN 0 "carg") (PRef fc n)) args)

1262

1263

1263− getConstraints (PPi (Constraint _ _) _ c sc)

1264+ getConstraints (PPi (Constraint _ _) _ _ c sc)

1264 = getcapp c ++ getConstraints sc

1265 = getcapp c ++ getConstraints sc

1265− getConstraints (PPi _ _ c sc) = getConstraints sc

1266+ getConstraints (PPi _ _ _ c sc) = getConstraints sc

1266 getConstraints _ = []

1267 getConstraints _ = []

1267

1268

1268 getcapp (PApp _ (PRef _ c) args)

1269 getcapp (PApp _ (PRef _ c) args)

@@ -1299,7 +1300,7 @@ addUsingImpls syn n fc t

1299 -- if all of args in ns, then add it

1300 -- if all of args in ns, then add it

1300 doAdd (UImplicit n ty : cs) ns t

1301 doAdd (UImplicit n ty : cs) ns t

1301 | elem n ns

1302 | elem n ns

1302− = PPi (Imp [] Dynamic False Nothing) n ty (doAdd cs ns t)

1303+ = PPi (Imp [] Dynamic False Nothing) n NoFC ty (doAdd cs ns t)

1303 | otherwise = doAdd cs ns t

1304 | otherwise = doAdd cs ns t

1304

1305

1305 -- bind the free names which weren't in the using block

1306 -- bind the free names which weren't in the using block

@@ -1307,9 +1308,9 @@ addUsingImpls syn n fc t

1307 bindFree (n:ns) tm

1308 bindFree (n:ns) tm

1308 | elem n (map iname uimpls) = bindFree ns tm

1309 | elem n (map iname uimpls) = bindFree ns tm

1309 | otherwise

1310 | otherwise

1310− = PPi (Imp [] Dynamic False Nothing) n Placeholder (bindFree ns tm)

1311+ = PPi (Imp [] Dynamic False Nothing) n NoFC Placeholder (bindFree ns tm)

1311

1312

1312− getArgnames (PPi _ n c sc)

1313+ getArgnames (PPi _ n _ c sc)

1313 = n : getArgnames sc

1314 = n : getArgnames sc

1314 getArgnames _ = []

1315 getArgnames _ = []

1315

1316

@@ -1318,7 +1319,7 @@ addUsingImpls syn n fc t

1318

1319

1319getUnboundImplicits :: IState -> Type -> PTerm -> [(Bool, PArg)]

1320getUnboundImplicits :: IState -> Type -> PTerm -> [(Bool, PArg)]

1320getUnboundImplicits i t tm = getImps t (collectImps tm)

1321getUnboundImplicits i t tm = getImps t (collectImps tm)

1321− where collectImps (PPi p n t sc)

1322+ where collectImps (PPi p n _ t sc)

1322 = (n, (p, t)) : collectImps sc

1323 = (n, (p, t)) : collectImps sc

1323 collectImps _ = []

1324 collectImps _ = []

1324

1325

@@ -1418,13 +1419,13 @@ implicitise syn ignore ist tm = -- trace ("INCOMING " ++ showImp True tm) $

1418 = do (decls, ns) <- get

1419 = do (decls, ns) <- get

1419 let isn = concatMap (namesIn uvars ist) (map getTm as)

1420 let isn = concatMap (namesIn uvars ist) (map getTm as)

1420 put (decls, nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls)))))

1421 put (decls, nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls)))))

1421− imps top env (PPi (Imp l _ _ _) n ty sc)

1422+ imps top env (PPi (Imp l _ _ _) n _ ty sc)

1422 = do let isn = nub (implNamesIn uvars ty) `dropAll` [n]

1423 = do let isn = nub (implNamesIn uvars ty) `dropAll` [n]

1423 (decls , ns) <- get

1424 (decls , ns) <- get

1424 put (PImp (getPriority ist ty) True l n Placeholder : decls,

1425 put (PImp (getPriority ist ty) True l n Placeholder : decls,

1425 nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls)))))

1426 nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls)))))

1426 imps True (n:env) sc

1427 imps True (n:env) sc

1427− imps top env (PPi (Exp l _ _) n ty sc)

1428+ imps top env (PPi (Exp l _ _) n _ ty sc)

1428 = do let isn = nub (implNamesIn uvars ty ++ case sc of

1429 = do let isn = nub (implNamesIn uvars ty ++ case sc of

1429 (PRef _ x) -> namesIn uvars ist sc `dropAll` [n]

1430 (PRef _ x) -> namesIn uvars ist sc `dropAll` [n]

1430 _ -> [])

1431 _ -> [])

@@ -1432,7 +1433,7 @@ implicitise syn ignore ist tm = -- trace ("INCOMING " ++ showImp True tm) $

1432 put (PExp (getPriority ist ty) l n Placeholder : decls,

1433 put (PExp (getPriority ist ty) l n Placeholder : decls,

1433 nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls)))))

1434 nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls)))))

1434 imps True (n:env) sc

1435 imps True (n:env) sc

1435− imps top env (PPi (Constraint l _) n ty sc)

1436+ imps top env (PPi (Constraint l _) n _ ty sc)

1436 = do let isn = nub (implNamesIn uvars ty ++ case sc of

1437 = do let isn = nub (implNamesIn uvars ty ++ case sc of

1437 (PRef _ x) -> namesIn uvars ist sc `dropAll` [n]

1438 (PRef _ x) -> namesIn uvars ist sc `dropAll` [n]

1438 _ -> [])

1439 _ -> [])

@@ -1440,7 +1441,7 @@ implicitise syn ignore ist tm = -- trace ("INCOMING " ++ showImp True tm) $

1440 put (PConstraint 10 l n Placeholder : decls,

1441 put (PConstraint 10 l n Placeholder : decls,

1441 nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls)))))

1442 nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls)))))

1442 imps True (n:env) sc

1443 imps True (n:env) sc

1443− imps top env (PPi (TacImp l _ scr) n ty sc)

1444+ imps top env (PPi (TacImp l _ scr) n _ ty sc)

1444 = do let isn = nub (implNamesIn uvars ty ++ case sc of

1445 = do let isn = nub (implNamesIn uvars ty ++ case sc of

1445 (PRef _ x) -> namesIn uvars ist sc `dropAll` [n]

1446 (PRef _ x) -> namesIn uvars ist sc `dropAll` [n]

1446 _ -> [])

1447 _ -> [])

@@ -1471,7 +1472,7 @@ implicitise syn ignore ist tm = -- trace ("INCOMING " ++ showImp True tm) $

1471 = do (decls, ns) <- get

1472 = do (decls, ns) <- get

1472 let isn = concatMap (namesIn uvars ist) as

1473 let isn = concatMap (namesIn uvars ist) as

1473 put (decls, nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls)))))

1474 put (decls, nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls)))))

1474− imps top env (PLam fc n ty sc)

1475+ imps top env (PLam fc n _ ty sc)

1475 = do imps False env ty

1476 = do imps False env ty

1476 imps False (n:env) sc

1477 imps False (n:env) sc

1477 imps top env (PHidden tm) = imps False env tm

1478 imps top env (PHidden tm) = imps False env tm

@@ -1483,8 +1484,8 @@ implicitise syn ignore ist tm = -- trace ("INCOMING " ++ showImp True tm) $

1483 pibind using [] sc = sc

1484 pibind using [] sc = sc

1484 pibind using (n:ns) sc

1485 pibind using (n:ns) sc

1485 = case lookup n using of

1486 = case lookup n using of

1486− Just ty -> PPi (Imp [] Dynamic False Nothing) n ty (pibind using ns sc)

1487+ Just ty -> PPi (Imp [] Dynamic False Nothing) n NoFC ty (pibind using ns sc)

1487− Nothing -> PPi (Imp [] Dynamic False Nothing) n Placeholder

1488+ Nothing -> PPi (Imp [] Dynamic False Nothing) n NoFC Placeholder

1488 (pibind using ns sc)

1489 (pibind using ns sc)

1489

1490

1490-- Add implicit arguments in function calls

1491-- Add implicit arguments in function calls

@@ -1514,9 +1515,9 @@ addImpl' inpat env infns imp_meths ist ptm

1514 ai :: Bool -> [(Name, Maybe PTerm)] -> [[T.Text]] -> PTerm -> PTerm

1515 ai :: Bool -> [(Name, Maybe PTerm)] -> [[T.Text]] -> PTerm -> PTerm

1515 ai qq env ds (PRef fc f)

1516 ai qq env ds (PRef fc f)

1516 | f `elem` infns = PInferRef fc f

1517 | f `elem` infns = PInferRef fc f

1517− | not (f `elem` map fst env) = handleErr $ aiFn inpat inpat qq imp_meths ist fc f ds []

1518+ | not (f `elem` map fst env) = handleErr $ aiFn inpat inpat qq imp_meths ist fc f fc ds []

1518 ai qq env ds (PHidden (PRef fc f))

1519 ai qq env ds (PHidden (PRef fc f))

1519− | not (f `elem` map fst env) = PHidden (handleErr $ aiFn inpat False qq imp_meths ist fc f ds [])

1520+ | not (f `elem` map fst env) = PHidden (handleErr $ aiFn inpat False qq imp_meths ist fc f fc ds [])

1520 ai qq env ds (PRewrite fc l r g)

1521 ai qq env ds (PRewrite fc l r g)

1521 = let l' = ai qq env ds l

1522 = let l' = ai qq env ds l

1522 r' = ai qq env ds r

1523 r' = ai qq env ds r

@@ -1539,14 +1540,14 @@ addImpl' inpat env infns imp_meths ist ptm

1539 = let as' = map (ai qq env ds) as in

1540 = let as' = map (ai qq env ds) as in

1540 PAlternative a as'

1541 PAlternative a as'

1541 ai qq env _ (PDisamb ds' as) = ai qq env ds' as

1542 ai qq env _ (PDisamb ds' as) = ai qq env ds' as

1542− ai qq env ds (PApp fc (PInferRef _ f) as)

1543+ ai qq env ds (PApp fc (PInferRef ffc f) as)

1543 = let as' = map (fmap (ai qq env ds)) as in

1544 = let as' = map (fmap (ai qq env ds)) as in

1544− PApp fc (PInferRef fc f) as'

1545+ PApp fc (PInferRef ffc f) as'

1545− ai qq env ds (PApp fc ftm@(PRef _ f) as)

1546+ ai qq env ds (PApp fc ftm@(PRef ffc f) as)

1546− | f `elem` infns = ai qq env ds (PApp fc (PInferRef fc f) as)

1547+ | f `elem` infns = ai qq env ds (PApp fc (PInferRef ffc f) as)

1547 | not (f `elem` map fst env)

1548 | not (f `elem` map fst env)

1548 = let as' = map (fmap (ai qq env ds)) as in

1549 = let as' = map (fmap (ai qq env ds)) as in

1549− handleErr $ aiFn inpat False qq imp_meths ist fc f ds as'

1550+ handleErr $ aiFn inpat False qq imp_meths ist fc f ffc ds as'

1550 | Just (Just ty) <- lookup f env =

1551 | Just (Just ty) <- lookup f env =

1551 let as' = map (fmap (ai qq env ds)) as

1552 let as' = map (fmap (ai qq env ds)) as

1552 arity = getPArity ty in

1553 arity = getPArity ty in

@@ -1561,33 +1562,35 @@ addImpl' inpat env infns imp_meths ist ptm

1561 -- definition which is passed through addImpl again with more scope

1562 -- definition which is passed through addImpl again with more scope

1562 -- information

1563 -- information

1563 PCase fc c' os

1564 PCase fc c' os

1564− -- If the name in a lambda is a constructor name, do this as a 'case'

1565+

1565− -- instead (it is harmless to do so, especially since the lambda will

1566− -- be lifted anyway!)

1567 ai qq env ds (PIfThenElse fc c t f) = PIfThenElse fc (ai qq env ds c)

1566 ai qq env ds (PIfThenElse fc c t f) = PIfThenElse fc (ai qq env ds c)

1568 (ai qq env ds t)

1567 (ai qq env ds t)

1569 (ai qq env ds f)

1568 (ai qq env ds f)

1569+

1570+ -- If the name in a lambda is a constructor name, do this as a 'case'

1571+ -- instead (it is harmless to do so, especially since the lambda will

1572+ -- be lifted anyway!)

1570− ai qq env ds (PLam fc n ty sc)

1573+ ai qq env ds (PLam fc n nfc ty sc)

1571 = case lookupDef n (tt_ctxt ist) of

1574 = case lookupDef n (tt_ctxt ist) of

1572 [] -> let ty' = ai qq env ds ty

1575 [] -> let ty' = ai qq env ds ty

1573 sc' = ai qq ((n, Just ty):env) ds sc in

1576 sc' = ai qq ((n, Just ty):env) ds sc in

1574− PLam fc n ty' sc'

1577+ PLam fc n nfc ty' sc'

1575− _ -> ai qq env ds (PLam fc (sMN 0 "lamp") ty

1578+ _ -> ai qq env ds (PLam fc (sMN 0 "lamp") NoFC ty

1576 (PCase fc (PRef fc (sMN 0 "lamp") )

1579 (PCase fc (PRef fc (sMN 0 "lamp") )

1577 [(PRef fc n, sc)]))

1580 [(PRef fc n, sc)]))

1578− ai qq env ds (PLet fc n ty val sc)

1581+ ai qq env ds (PLet fc n nfc ty val sc)

1579 = case lookupDef n (tt_ctxt ist) of

1582 = case lookupDef n (tt_ctxt ist) of

1580 [] -> let ty' = ai qq env ds ty

1583 [] -> let ty' = ai qq env ds ty

1581 val' = ai qq env ds val

1584 val' = ai qq env ds val

1582 sc' = ai qq ((n, Just ty):env) ds sc in

1585 sc' = ai qq ((n, Just ty):env) ds sc in

1583− PLet fc n ty' val' sc'

1586+ PLet fc n nfc ty' val' sc'

1584 _ -> ai qq env ds (PCase fc val [(PRef fc n, sc)])

1587 _ -> ai qq env ds (PCase fc val [(PRef fc n, sc)])

1585− ai qq env ds (PPi p n ty sc)

1588+ ai qq env ds (PPi p n nfc ty sc)

1586 = let ty' = ai qq env ds ty

1589 = let ty' = ai qq env ds ty

1587 env' = if n `elem` imp_meths then env

1590 env' = if n `elem` imp_meths then env

1588 else ((n, Just ty) : env)

1591 else ((n, Just ty) : env)

1589 sc' = ai qq env' ds sc in

1592 sc' = ai qq env' ds sc in

1590− PPi p n ty' sc'

1593+ PPi p n nfc ty' sc'

1591 ai qq env ds (PGoal fc r n sc)

1594 ai qq env ds (PGoal fc r n sc)

1592 = let r' = ai qq env ds r

1595 = let r' = ai qq env ds r

1593 sc' = ai qq ((n, Nothing):env) ds sc in

1596 sc' = ai qq ((n, Nothing):env) ds sc in

@@ -1609,17 +1612,17 @@ addImpl' inpat env infns imp_meths ist ptm

1609-- if in a pattern, and there are no arguments, and there's no possible

1612-- if in a pattern, and there are no arguments, and there's no possible

1610-- names with zero explicit arguments, don't add implicits.

1613-- names with zero explicit arguments, don't add implicits.

1611

1614

1612−aiFn :: Bool -> Bool -> Bool -> [Name] -> IState -> FC -> Name -> [[T.Text]] -> [PArg] -> Either Err PTerm

1615+aiFn :: Bool -> Bool -> Bool -> [Name] -> IState -> FC -> Name -> FC -> [[T.Text]] -> [PArg] -> Either Err PTerm

1613−aiFn inpat True qq imp_meths ist fc f ds []

1616+aiFn inpat True qq imp_meths ist fc f ffc ds []

1614 = case lookupDef f (tt_ctxt ist) of

1617 = case lookupDef f (tt_ctxt ist) of

1615− [] -> Right $ PPatvar fc f

1618+ [] -> Right $ PPatvar ffc f

1616 alts -> let ialts = lookupCtxtName f (idris_implicits ist) in

1619 alts -> let ialts = lookupCtxtName f (idris_implicits ist) in

1617 -- trace (show f ++ " " ++ show (fc, any (all imp) ialts, ialts, any constructor alts)) $

1620 -- trace (show f ++ " " ++ show (fc, any (all imp) ialts, ialts, any constructor alts)) $

1618 if (not (vname f) || tcname f

1621 if (not (vname f) || tcname f

1619 || any (conCaf (tt_ctxt ist)) ialts)

1622 || any (conCaf (tt_ctxt ist)) ialts)

1620-- any constructor alts || any allImp ialts))

1623-- any constructor alts || any allImp ialts))

1621− then aiFn inpat False qq imp_meths ist fc f ds [] -- use it as a constructor

1624+ then aiFn inpat False qq imp_meths ist fc f ffc ds [] -- use it as a constructor

1622− else Right $ PPatvar fc f

1625+ else Right $ PPatvar ffc f

1623 where imp (PExp _ _ _ _) = False

1626 where imp (PExp _ _ _ _) = False

1624 imp _ = True

1627 imp _ = True

1625-- allImp [] = False

1628-- allImp [] = False

@@ -1632,9 +1635,9 @@ aiFn inpat True qq imp_meths ist fc f ds []

1632 vname (UN n) = True -- non qualified

1635 vname (UN n) = True -- non qualified

1633 vname _ = False

1636 vname _ = False

1634

1637

1635−aiFn inpat expat qq imp_meths ist fc f ds as

1638+aiFn inpat expat qq imp_meths ist fc f ffc ds as

1636− | f `elem` primNames = Right $ PApp fc (PRef fc f) as

1639+ | f `elem` primNames = Right $ PApp fc (PRef ffc f) as

1637−aiFn inpat expat qq imp_meths ist fc f ds as

1640+aiFn inpat expat qq imp_meths ist fc f ffc ds as

1638 -- This is where namespaces get resolved by adding PAlternative

1641 -- This is where namespaces get resolved by adding PAlternative

1639 = do let ns = lookupCtxtName f (idris_implicits ist)

1642 = do let ns = lookupCtxtName f (idris_implicits ist)

1640 let nh = filter (\(n, _) -> notHidden n) ns

1643 let nh = filter (\(n, _) -> notHidden n) ns

@@ -1642,13 +1645,13 @@ aiFn inpat expat qq imp_meths ist fc f ds as

1642 [] -> nh

1645 [] -> nh

1643 x -> x

1646 x -> x

1644 case ns' of

1647 case ns' of

1645− [(f',ns)] -> Right $ mkPApp fc (length ns) (PRef fc (isImpName f f')) (insertImpl ns as)

1648+ [(f',ns)] -> Right $ mkPApp fc (length ns) (PRef ffc (isImpName f f')) (insertImpl ns as)

1646 [] -> if f `elem` (map fst (idris_metavars ist))

1649 [] -> if f `elem` (map fst (idris_metavars ist))

1647− then Right $ PApp fc (PRef fc f) as

1650+ then Right $ PApp fc (PRef ffc f) as

1648− else Right $ mkPApp fc (length as) (PRef fc f) as

1651+ else Right $ mkPApp fc (length as) (PRef ffc f) as

1649 alts -> Right $

1652 alts -> Right $

1650 PAlternative True $

1653 PAlternative True $

1651− map (\(f', ns) -> mkPApp fc (length ns) (PRef fc (isImpName f f'))

1654+ map (\(f', ns) -> mkPApp fc (length ns) (PRef ffc (isImpName f f'))

1652 (insertImpl ns as)) alts

1655 (insertImpl ns as)) alts

1653 where

1656 where

1654 -- if the name is in imp_meths, we should actually refer to the bound

1657 -- if the name is in imp_meths, we should actually refer to the bound

@@ -1673,7 +1676,7 @@ aiFn inpat expat qq imp_meths ist fc f ds as

1673 _ -> Public

1676 _ -> Public

1674

1677

1675 insertImpl :: [PArg] -> [PArg] -> [PArg]

1678 insertImpl :: [PArg] -> [PArg] -> [PArg]

1676− insertImpl ps as = insImpAcc M.empty ps (filter exp as) (filter (not.exp) as)

1679+ insertImpl ps as = insImpAcc M.empty ps (filter exp as) (filter (not . exp) as)

1677

1680

1678 exp (PExp _ _ _ _) = True

1681 exp (PExp _ _ _ _) = True

1679 exp (PConstraint _ _ _ _) = True

1682 exp (PConstraint _ _ _ _) = True

@@ -1774,10 +1777,9 @@ stripLinear i tm = evalState (sl tm) [] where

1774 return $ PTacImplicit p l n sc t'

1777 return $ PTacImplicit p l n sc t'

1775 sl x = return x

1778 sl x = return x

1776

1779

1777−-- Remove functions which aren't applied to anything, which must then

1780+-- | Remove functions which aren't applied to anything, which must then

1778-- be resolved by unification. Assume names resolved and alternatives

1781-- be resolved by unification. Assume names resolved and alternatives

1779-- filled in (so no ambiguity).

1782-- filled in (so no ambiguity).

1780−

1781stripUnmatchable :: IState -> PTerm -> PTerm

1783stripUnmatchable :: IState -> PTerm -> PTerm

1782stripUnmatchable i (PApp fc fn args) = PApp fc fn (fmap (fmap su) args) where

1784stripUnmatchable i (PApp fc fn args) = PApp fc fn (fmap (fmap su) args) where

1783 su :: PTerm -> PTerm

1785 su :: PTerm -> PTerm

@@ -1799,8 +1801,8 @@ stripUnmatchable i (PApp fc fn args) = PApp fc fn (fmap (fmap su) args) where

1799 else PAlternative b alts'

1801 else PAlternative b alts'

1800 su (PPair fc p l r) = PPair fc p (su l) (su r)

1802 su (PPair fc p l r) = PPair fc p (su l) (su r)

1801 su (PDPair fc p l t r) = PDPair fc p (su l) (su t) (su r)

1803 su (PDPair fc p l t r) = PDPair fc p (su l) (su t) (su r)

1802− su t@(PLam fc _ _ _) = PHidden t

1804+ su t@(PLam fc _ _ _ _) = PHidden t

1803− su t@(PPi _ _ _ _) = PHidden t

1805+ su t@(PPi _ _ _ _ _) = PHidden t

1804 su t = t

1806 su t = t

1805

1807

1806 ctxt = tt_ctxt i

1808 ctxt = tt_ctxt i

@@ -1823,7 +1825,7 @@ findStatics :: IState -> PTerm -> (PTerm, [Bool])

1823findStatics ist tm = trace (show tm) $

1825findStatics ist tm = trace (show tm) $

1824 let (ns, ss) = fs tm in

1826 let (ns, ss) = fs tm in

1825 runState (pos ns ss tm) []

1827 runState (pos ns ss tm) []

1826− where fs (PPi p n t sc)

1828+ where fs (PPi p n fc t sc)

1827 | Static <- pstatic p

1829 | Static <- pstatic p

1828 = let (ns, ss) = fs sc in

1830 = let (ns, ss) = fs sc in

1829 (namesIn [] ist t : ns, n : ss)

1831 (namesIn [] ist t : ns, n : ss)

@@ -1833,15 +1835,15 @@ findStatics ist tm = trace (show tm) $

1833

1835

1834 inOne n ns = length (filter id (map (elem n) ns)) == 1

1836 inOne n ns = length (filter id (map (elem n) ns)) == 1

1835

1837

1836− pos ns ss (PPi p n t sc)

1838+ pos ns ss (PPi p n fc t sc)

1837 | elem n ss = do sc' <- pos ns ss sc

1839 | elem n ss = do sc' <- pos ns ss sc

1838 spos <- get

1840 spos <- get

1839 put (True : spos)

1841 put (True : spos)

1840− return (PPi (p { pstatic = Static }) n t sc')

1842+ return (PPi (p { pstatic = Static }) n fc t sc')

1841 | otherwise = do sc' <- pos ns ss sc

1843 | otherwise = do sc' <- pos ns ss sc

1842 spos <- get

1844 spos <- get

1843 put (False : spos)

1845 put (False : spos)

1844− return (PPi p n t sc')

1846+ return (PPi p n fc t sc')

1845 pos ns ss t = return t

1847 pos ns ss t = return t

1846

1848

1847-- for 6.12/7 compatibility

1849-- for 6.12/7 compatibility

@@ -1875,10 +1877,10 @@ matchClause' names i x y = checkRpts $ match (fullApp x) (fullApp y) where

1875 match' x y = match (fullApp x) (fullApp y)

1877 match' x y = match (fullApp x) (fullApp y)

1876 match (PApp _ (PRef _ (NS (UN fi) [b])) [_,_,x]) x'

1878 match (PApp _ (PRef _ (NS (UN fi) [b])) [_,_,x]) x'

1877 | fi == txt "fromInteger" && b == txt "builtins",

1879 | fi == txt "fromInteger" && b == txt "builtins",

1878− PConstant (I _) <- getTm x = match (getTm x) x'

1880+ PConstant _ (I _) <- getTm x = match (getTm x) x'

1879 match x' (PApp _ (PRef _ (NS (UN fi) [b])) [_,_,x])

1881 match x' (PApp _ (PRef _ (NS (UN fi) [b])) [_,_,x])

1880 | fi == txt "fromInteger" && b == txt "builtins",

1882 | fi == txt "fromInteger" && b == txt "builtins",

1881− PConstant (I _) <- getTm x = match (getTm x) x'

1883+ PConstant _ (I _) <- getTm x = match (getTm x) x'

1882 match (PApp _ (PRef _ (UN l)) [_,x]) x' | l == txt "lazy" = match (getTm x) x'

1884 match (PApp _ (PRef _ (UN l)) [_,x]) x' | l == txt "lazy" = match (getTm x) x'

1883 match x (PApp _ (PRef _ (UN l)) [_,x']) | l == txt "lazy" = match x (getTm x')

1885 match x (PApp _ (PRef _ (UN l)) [_,x']) | l == txt "lazy" = match x (getTm x')

1884 match (PApp _ f args) (PApp _ f' args')

1886 match (PApp _ f args) (PApp _ f' args')

@@ -1936,16 +1938,16 @@ matchClause' names i x y = checkRpts $ match (fullApp x) (fullApp y) where

1936 match (PResolveTC _) (PResolveTC _) = return []

1938 match (PResolveTC _) (PResolveTC _) = return []

1937 match (PTrue _ _) (PTrue _ _) = return []

1939 match (PTrue _ _) (PTrue _ _) = return []

1938 match (PReturn _) (PReturn _) = return []

1940 match (PReturn _) (PReturn _) = return []

1939− match (PPi _ _ t s) (PPi _ _ t' s') = do mt <- match' t t'

1941+ match (PPi _ _ _ t s) (PPi _ _ _ t' s') = do mt <- match' t t'

1940− ms <- match' s s'

1942+ ms <- match' s s'

1941− return (mt ++ ms)

1943+ return (mt ++ ms)

1942− match (PLam _ _ t s) (PLam _ _ t' s') = do mt <- match' t t'

1944+ match (PLam _ _ _ t s) (PLam _ _ _ t' s') = do mt <- match' t t'

1943− ms <- match' s s'

1945+ ms <- match' s s'

1944− return (mt ++ ms)

1946+ return (mt ++ ms)

1945− match (PLet _ _ t ty s) (PLet _ _ t' ty' s') = do mt <- match' t t'

1947+ match (PLet _ _ _ t ty s) (PLet _ _ _ t' ty' s') = do mt <- match' t t'

1946− mty <- match' ty ty'

1948+ mty <- match' ty ty'

1947− ms <- match' s s'

1949+ ms <- match' s s'

1948− return (mt ++ mty ++ ms)

1950+ return (mt ++ mty ++ ms)

1949 match (PHidden x) (PHidden y)

1951 match (PHidden x) (PHidden y)

1950 | RightOK xs <- match x y = return xs -- to collect variables

1952 | RightOK xs <- match x y = return xs -- to collect variables

1951 | otherwise = return [] -- Otherwise hidden things are unmatchable

1953 | otherwise = return [] -- Otherwise hidden things are unmatchable

@@ -1988,13 +1990,13 @@ substMatch n = substMatchShadow n []

1988substMatchShadow :: Name -> [Name] -> PTerm -> PTerm -> PTerm

1990substMatchShadow :: Name -> [Name] -> PTerm -> PTerm -> PTerm

1989substMatchShadow n shs tm t = sm shs t where

1991substMatchShadow n shs tm t = sm shs t where

1990 sm xs (PRef _ n') | n == n' = tm

1992 sm xs (PRef _ n') | n == n' = tm

1991− sm xs (PLam fc x t sc) = PLam fc x (sm xs t) (sm xs sc)

1993+ sm xs (PLam fc x xfc t sc) = PLam fc x xfc (sm xs t) (sm xs sc)

1992− sm xs (PPi p x t sc)

1994+ sm xs (PPi p x fc t sc)

1993 | x `elem` xs

1995 | x `elem` xs

1994 = let x' = nextName x in

1996 = let x' = nextName x in

1995− PPi p x' (sm (x':xs) (substMatch x (PRef emptyFC x') t))

1997+ PPi p x' fc (sm (x':xs) (substMatch x (PRef emptyFC x') t))

1996− (sm (x':xs) (substMatch x (PRef emptyFC x') sc))

1998+ (sm (x':xs) (substMatch x (PRef emptyFC x') sc))

1997− | otherwise = PPi p x (sm xs t) (sm (x : xs) sc)

1999+ | otherwise = PPi p x fc (sm xs t) (sm (x : xs) sc)

1998 sm xs (PApp f x as) = fullApp $ PApp f (sm xs x) (map (fmap (sm xs)) as)

2000 sm xs (PApp f x as) = fullApp $ PApp f (sm xs x) (map (fmap (sm xs)) as)

1999 sm xs (PCase f x as) = PCase f (sm xs x) (map (pmap (sm xs)) as)

2001 sm xs (PCase f x as) = PCase f (sm xs x) (map (pmap (sm xs)) as)

2000 sm xs (PIfThenElse fc c t f) = PIfThenElse fc (sm xs c) (sm xs t) (sm xs f)

2002 sm xs (PIfThenElse fc c t f) = PIfThenElse fc (sm xs c) (sm xs t) (sm xs f)

@@ -2016,12 +2018,12 @@ substMatchShadow n shs tm t = sm shs t where

2016shadow :: Name -> Name -> PTerm -> PTerm

2018shadow :: Name -> Name -> PTerm -> PTerm

2017shadow n n' t = sm t where

2019shadow n n' t = sm t where

2018 sm (PRef fc x) | n == x = PRef fc n'

2020 sm (PRef fc x) | n == x = PRef fc n'

2019− sm (PLam fc x t sc) | n /= x = PLam fc x (sm t) (sm sc)

2021+ sm (PLam fc x xfc t sc) | n /= x = PLam fc x xfc (sm t) (sm sc)

2020− | otherwise = PLam fc x (sm t) sc

2022+ | otherwise = PLam fc x xfc (sm t) sc

2021− sm (PPi p x t sc) | n /= x = PPi p x (sm t) (sm sc)

2023+ sm (PPi p x fc t sc) | n /= x = PPi p x fc (sm t) (sm sc)

2022− | otherwise = PPi p x (sm t) sc

2024+ | otherwise = PPi p x fc (sm t) sc

2023− sm (PLet fc x t v sc) | n /= x = PLet fc x (sm t) (sm v) (sm sc)

2025+ sm (PLet fc x xfc t v sc) | n /= x = PLet fc x xfc (sm t) (sm v) (sm sc)

2024− | otherwise = PLet fc x (sm t) (sm v) sc

2026+ | otherwise = PLet fc x xfc (sm t) (sm v) sc

2025 sm (PApp f x as) = PApp f (sm x) (map (fmap sm) as)

2027 sm (PApp f x as) = PApp f (sm x) (map (fmap sm) as)

2026 sm (PAppBind f x as) = PAppBind f (sm x) (map (fmap sm) as)

2028 sm (PAppBind f x as) = PAppBind f (sm x) (map (fmap sm) as)

2027 sm (PCase f x as) = PCase f (sm x) (map (pmap sm) as)

2029 sm (PCase f x as) = PCase f (sm x) (map (pmap sm) as)

@@ -2060,7 +2062,7 @@ mkUniqueNames env tm = evalState (mkUniq tm) (S.fromList env) where

2060 mkUniqT tac = return tac

2062 mkUniqT tac = return tac

2061

2063

2062 mkUniq :: PTerm -> State (S.Set Name) PTerm

2064 mkUniq :: PTerm -> State (S.Set Name) PTerm

2063− mkUniq (PLam fc n ty sc)

2065+ mkUniq (PLam fc n nfc ty sc)

2064 = do env <- get

2066 = do env <- get

2065 (n', sc') <-

2067 (n', sc') <-

2066 if n `S.member` env

2068 if n `S.member` env

@@ -2071,8 +2073,8 @@ mkUniqueNames env tm = evalState (mkUniq tm) (S.fromList env) where

2071 put (S.insert n' env)

2073 put (S.insert n' env)

2072 ty' <- mkUniq ty

2074 ty' <- mkUniq ty

2073 sc'' <- mkUniq sc'

2075 sc'' <- mkUniq sc'

2074− return $! PLam fc n' ty' sc''

2076+ return $! PLam fc n' nfc ty' sc''

2075− mkUniq (PPi p n ty sc)

2077+ mkUniq (PPi p n fc ty sc)

2076 = do env <- get

2078 = do env <- get

2077 (n', sc') <-

2079 (n', sc') <-

2078 if n `S.member` env

2080 if n `S.member` env

@@ -2083,8 +2085,8 @@ mkUniqueNames env tm = evalState (mkUniq tm) (S.fromList env) where

2083 put (S.insert n' env)

2085 put (S.insert n' env)

2084 ty' <- mkUniq ty

2086 ty' <- mkUniq ty

2085 sc'' <- mkUniq sc'

2087 sc'' <- mkUniq sc'

2086− return $! PPi p n' ty' sc''

2088+ return $! PPi p n' fc ty' sc''

2087− mkUniq (PLet fc n ty val sc)

2089+ mkUniq (PLet fc n nfc ty val sc)

2088 = do env <- get

2090 = do env <- get

2089 (n', sc') <-

2091 (n', sc') <-

2090 if n `S.member` env

2092 if n `S.member` env

@@ -2095,7 +2097,7 @@ mkUniqueNames env tm = evalState (mkUniq tm) (S.fromList env) where

2095 put (S.insert n' env)

2097 put (S.insert n' env)

2096 ty' <- mkUniq ty; val' <- mkUniq val

2098 ty' <- mkUniq ty; val' <- mkUniq val

2097 sc'' <- mkUniq sc'

2099 sc'' <- mkUniq sc'

2098− return $! PLet fc n' ty' val' sc''

2100+ return $! PLet fc n' nfc ty' val' sc''

2099 mkUniq (PApp fc t args)

2101 mkUniq (PApp fc t args)

2100 = do t' <- mkUniq t

2102 = do t' <- mkUniq t

2101 args' <- mapM mkUniqA args

2103 args' <- mapM mkUniqA args

src/Idris/AbsSyntaxTree.hs+109−100

@@ -593,7 +593,7 @@ type ProvideWhat = ProvideWhat' PTerm

593-- datatypes and typeclasses.

594data PDecl' t

595 = PFix FC Fixity [String] -- ^ Fixity declaration

596− | PTy (Docstring (Either Err PTerm)) [(Name, Docstring (Either Err PTerm))] SyntaxInfo FC FnOpts Name t -- ^ Type declaration

596+ | PTy (Docstring (Either Err PTerm)) [(Name, Docstring (Either Err PTerm))] SyntaxInfo FC FnOpts Name FC t -- ^ Type declaration (last FC is precise name location)

597 | PPostulate Bool -- external def if true

598 (Docstring (Either Err PTerm)) SyntaxInfo FC FnOpts Name t -- ^ Postulate

599 | PClauses FC FnOpts Name [PClause' t] -- ^ Pattern clause

@@ -603,30 +603,33 @@ data PDecl' t

603 | PNamespace String [PDecl' t] -- ^ New namespace

604 | PRecord (Docstring (Either Err PTerm)) SyntaxInfo FC DataOpts

605 Name -- Record name

606+ FC -- Record name precise location

606− [(Name, Plicity, t)] -- Parameters

607+ [(Name, FC, Plicity, t)] -- Parameters, where FC is precise name span

607 [(Name, Docstring (Either Err PTerm))] -- Param Docs

608 [(Name, Docstring (Either Err PTerm))] -- Param Docs

608− [((Maybe Name), Plicity, t, Maybe (Docstring (Either Err PTerm)))] -- Fields

609+ [((Maybe (Name, FC)), Plicity, t, Maybe (Docstring (Either Err PTerm)))] -- Fields

609− (Maybe Name) -- Optional constructor name

610+ (Maybe (Name, FC)) -- Optional constructor name and location

610 (Docstring (Either Err PTerm)) -- Constructor doc

611 (Docstring (Either Err PTerm)) -- Constructor doc

611 SyntaxInfo -- Constructor SyntaxInfo

612 SyntaxInfo -- Constructor SyntaxInfo

612 -- ^ Record declaration

613 -- ^ Record declaration

613 | PClass (Docstring (Either Err PTerm)) SyntaxInfo FC

614 | PClass (Docstring (Either Err PTerm)) SyntaxInfo FC

614 [(Name, t)] -- constraints

615 [(Name, t)] -- constraints

615 Name -- class name

616 Name -- class name

617+ FC -- accurate location of class name

616− [(Name, t)] -- parameters

618+ [(Name, FC, t)] -- parameters and precise locations

617 [(Name, Docstring (Either Err PTerm))] -- parameter docstrings

619 [(Name, Docstring (Either Err PTerm))] -- parameter docstrings

618− [Name] -- determining parameters

620+ [(Name, FC)] -- determining parameters and precise locations

619 [PDecl' t] -- declarations

621 [PDecl' t] -- declarations

620− (Maybe Name) -- instance constructor name

622+ (Maybe (Name, FC)) -- instance constructor name and location

621 (Docstring (Either Err PTerm)) -- instance constructor docs

623 (Docstring (Either Err PTerm)) -- instance constructor docs

622 -- ^ Type class: arguments are documentation, syntax info, source location, constraints,

624 -- ^ Type class: arguments are documentation, syntax info, source location, constraints,

623− -- class name, parameters, method declarations, optional constructor name

625+ -- class name, class name location, parameters, method declarations, optional constructor name

624 | PInstance

626 | PInstance

625 (Docstring (Either Err PTerm)) -- Instance docs

627 (Docstring (Either Err PTerm)) -- Instance docs

626 [(Name, Docstring (Either Err PTerm))] -- Parameter docs

628 [(Name, Docstring (Either Err PTerm))] -- Parameter docs

627 SyntaxInfo

629 SyntaxInfo

628 FC [(Name, t)] -- constraints

630 FC [(Name, t)] -- constraints

629 Name -- class

631 Name -- class

632+ FC -- precise location of class

630 [t] -- parameters

633 [t] -- parameters

631 t -- full instance type

634 t -- full instance type

632 (Maybe Name) -- explicit name

635 (Maybe Name) -- explicit name

@@ -672,14 +675,19 @@ data RDeclInstructions = RTyDeclInstrs Name FC [PArg] Type

672data EState = EState {

675data EState = EState {

673 case_decls :: [(Name, PDecl)],

676 case_decls :: [(Name, PDecl)],

674 delayed_elab :: [Elab' EState ()],

677 delayed_elab :: [Elab' EState ()],

675− new_tyDecls :: [RDeclInstructions]

678+ new_tyDecls :: [RDeclInstructions],

679+ highlighting :: [(FC, OutputAnnotation)]

676 }

680 }

677

681

678initEState :: EState

682initEState :: EState

679−initEState = EState [] [] []

683+initEState = EState [] [] [] []

680

684

681type ElabD a = Elab' EState a

685type ElabD a = Elab' EState a

682

686

687+highlightSource :: FC -> OutputAnnotation -> ElabD ()

688+highlightSource fc annot =

689+ updateAux (\aux -> aux { highlighting = (fc, annot) : highlighting aux })

690+

683-- | One clause of a top-level definition. Term arguments to constructors are:

691-- | One clause of a top-level definition. Term arguments to constructors are:

684--

692--

685-- 1. The whole application (missing for PClauseR and PWithR because they're within a "with" clause)

693-- 1. The whole application (missing for PClauseR and PWithR because they're within a "with" clause)

@@ -690,10 +698,10 @@ type ElabD a = Elab' EState a

690--

698--

691-- 4. The where block (PDecl' t)

699-- 4. The where block (PDecl' t)

692

700

693−data PClause' t = PClause FC Name t [t] t [PDecl' t] -- ^ A normal top-level definition.

701+data PClause' t = PClause FC Name t [t] t [PDecl' t] -- ^ A normal top-level definition.

694− | PWith FC Name t [t] t (Maybe Name) [PDecl' t]

702+ | PWith FC Name t [t] t (Maybe (Name, FC)) [PDecl' t]

695− | PClauseR FC [t] t [PDecl' t]

703+ | PClauseR FC [t] t [PDecl' t]

696− | PWithR FC [t] t (Maybe Name) [PDecl' t]

704+ | PWithR FC [t] t (Maybe (Name, FC)) [PDecl' t]

697 deriving Functor

705 deriving Functor

698{-!

706{-!

699deriving instance Binary PClause'

707deriving instance Binary PClause'

@@ -702,11 +710,12 @@ deriving instance NFData PClause'

702

710

703-- | Data declaration

711-- | Data declaration

704data PData' t = PDatadecl { d_name :: Name, -- ^ The name of the datatype

712data PData' t = PDatadecl { d_name :: Name, -- ^ The name of the datatype

713+ d_name_fc :: FC, -- ^ The precise location of the type constructor name

705 d_tcon :: t, -- ^ Type constructor

714 d_tcon :: t, -- ^ Type constructor

706− d_cons :: [(Docstring (Either Err PTerm), [(Name, Docstring (Either Err PTerm))], Name, t, FC, [Name])] -- ^ Constructors

715+ d_cons :: [(Docstring (Either Err PTerm), [(Name, Docstring (Either Err PTerm))], Name, FC, t, FC, [Name])] -- ^ Constructors

707 }

716 }

708 -- ^ Data declaration

717 -- ^ Data declaration

709− | PLaterdecl { d_name :: Name, d_tcon :: t }

718+ | PLaterdecl { d_name :: Name, d_name_fc :: FC, d_tcon :: t }

710 -- ^ "Placeholder" for data whose constructors are defined later

719 -- ^ "Placeholder" for data whose constructors are defined later

711 deriving Functor

720 deriving Functor

712{-!

721{-!

@@ -725,18 +734,18 @@ type PClause = PClause' PTerm

725

734

726declared :: PDecl -> [Name]

735declared :: PDecl -> [Name]

727declared (PFix _ _ _) = []

736declared (PFix _ _ _) = []

728−declared (PTy _ _ _ _ _ n t) = [n]

737+declared (PTy _ _ _ _ _ n fc t) = [n]

729declared (PPostulate _ _ _ _ _ n t) = [n]

738declared (PPostulate _ _ _ _ _ n t) = [n]

730declared (PClauses _ _ n _) = [] -- not a declaration

739declared (PClauses _ _ n _) = [] -- not a declaration

731declared (PCAF _ n _) = [n]

740declared (PCAF _ n _) = [n]

732−declared (PData _ _ _ _ _ (PDatadecl n _ ts)) = n : map fstt ts

741+declared (PData _ _ _ _ _ (PDatadecl n _ _ ts)) = n : map fstt ts

733− where fstt (_, _, a, _, _, _) = a

742+ where fstt (_, _, a, _, _, _, _) = a

734−declared (PData _ _ _ _ _ (PLaterdecl n _)) = [n]

743+declared (PData _ _ _ _ _ (PLaterdecl n _ _)) = [n]

735declared (PParams _ _ ds) = concatMap declared ds

744declared (PParams _ _ ds) = concatMap declared ds

736declared (PNamespace _ ds) = concatMap declared ds

745declared (PNamespace _ ds) = concatMap declared ds

737−declared (PRecord _ _ _ _ n _ _ _ cn _ _) = n : maybeToList cn

746+declared (PRecord _ _ _ _ n _ _ _ _ cn _ _) = n : map fst (maybeToList cn)

738−declared (PClass _ _ _ _ n _ _ _ ms cn cd) = n : (maybeToList cn ++ concatMap declared ms)

747+declared (PClass _ _ _ _ n _ _ _ _ ms cn cd) = n : (map fst (maybeToList cn) ++ concatMap declared ms)

739−declared (PInstance _ _ _ _ _ _ _ _ _ _) = []

748+declared (PInstance _ _ _ _ _ _ _ _ _ _ _) = []

740declared (PDSL n _) = [n]

749declared (PDSL n _) = [n]

741declared (PSyntax _ _) = []

750declared (PSyntax _ _) = []

742declared (PMutual _ ds) = concatMap declared ds

751declared (PMutual _ ds) = concatMap declared ds

@@ -746,33 +755,33 @@ declared _ = []

746-- get the names declared, not counting nested parameter blocks

755-- get the names declared, not counting nested parameter blocks

747tldeclared :: PDecl -> [Name]

756tldeclared :: PDecl -> [Name]

748tldeclared (PFix _ _ _) = []

757tldeclared (PFix _ _ _) = []

749−tldeclared (PTy _ _ _ _ _ n t) = [n]

758+tldeclared (PTy _ _ _ _ _ n _ t) = [n]

750tldeclared (PPostulate _ _ _ _ _ n t) = [n]

759tldeclared (PPostulate _ _ _ _ _ n t) = [n]

751tldeclared (PClauses _ _ n _) = [] -- not a declaration

760tldeclared (PClauses _ _ n _) = [] -- not a declaration

752−tldeclared (PRecord _ _ _ _ n _ _ _ cn _ _) = n : maybeToList cn

761+tldeclared (PRecord _ _ _ _ n _ _ _ _ cn _ _) = n : map fst (maybeToList cn)

753−tldeclared (PData _ _ _ _ _ (PDatadecl n _ ts)) = n : map fstt ts

762+tldeclared (PData _ _ _ _ _ (PDatadecl n _ _ ts)) = n : map fstt ts

754− where fstt (_, _, a, _, _, _) = a

763+ where fstt (_, _, a, _, _, _, _) = a

755tldeclared (PParams _ _ ds) = []

764tldeclared (PParams _ _ ds) = []

756tldeclared (PMutual _ ds) = concatMap tldeclared ds

765tldeclared (PMutual _ ds) = concatMap tldeclared ds

757tldeclared (PNamespace _ ds) = concatMap tldeclared ds

766tldeclared (PNamespace _ ds) = concatMap tldeclared ds

758−tldeclared (PClass _ _ _ _ n _ _ _ ms cn _) = n : (maybeToList cn ++ concatMap tldeclared ms)

767+tldeclared (PClass _ _ _ _ n _ _ _ _ ms cn _) = n : (map fst (maybeToList cn) ++ concatMap tldeclared ms)

759−tldeclared (PInstance _ _ _ _ _ _ _ _ _ _) = []

768+tldeclared (PInstance _ _ _ _ _ _ _ _ _ _ _) = []

760tldeclared _ = []

769tldeclared _ = []

761

770

762defined :: PDecl -> [Name]

771defined :: PDecl -> [Name]

763defined (PFix _ _ _) = []

772defined (PFix _ _ _) = []

764−defined (PTy _ _ _ _ _ n t) = []

773+defined (PTy _ _ _ _ _ n _ t) = []

765defined (PPostulate _ _ _ _ _ n t) = []

774defined (PPostulate _ _ _ _ _ n t) = []

766defined (PClauses _ _ n _) = [n] -- not a declaration

775defined (PClauses _ _ n _) = [n] -- not a declaration

767defined (PCAF _ n _) = [n]

776defined (PCAF _ n _) = [n]

768−defined (PData _ _ _ _ _ (PDatadecl n _ ts)) = n : map fstt ts

777+defined (PData _ _ _ _ _ (PDatadecl n _ _ ts)) = n : map fstt ts

769− where fstt (_, _, a, _, _, _) = a

778+ where fstt (_, _, a, _, _, _, _) = a

770−defined (PData _ _ _ _ _ (PLaterdecl n _)) = []

779+defined (PData _ _ _ _ _ (PLaterdecl n _ _)) = []

771defined (PParams _ _ ds) = concatMap defined ds

780defined (PParams _ _ ds) = concatMap defined ds

772defined (PNamespace _ ds) = concatMap defined ds

781defined (PNamespace _ ds) = concatMap defined ds

773−defined (PRecord _ _ _ _ n _ _ _ cn _ _) = n : maybeToList cn

782+defined (PRecord _ _ _ _ n _ _ _ _ cn _ _) = n : map fst (maybeToList cn)

774−defined (PClass _ _ _ _ n _ _ _ ms cn _) = n : (maybeToList cn ++ concatMap defined ms)

783+defined (PClass _ _ _ _ n _ _ _ _ ms cn _) = n : (map fst (maybeToList cn) ++ concatMap defined ms)

775−defined (PInstance _ _ _ _ _ _ _ _ _ _) = []

784+defined (PInstance _ _ _ _ _ _ _ _ _ _ _) = []

776defined (PDSL n _) = [n]

785defined (PDSL n _) = [n]

777defined (PSyntax _ _) = []

786defined (PSyntax _ _) = []

778defined (PMutual _ ds) = concatMap defined ds

787defined (PMutual _ ds) = concatMap defined ds

@@ -807,9 +816,9 @@ data PTerm = PQuote Raw -- ^ Inclusion of a core term into the high-level langua

807 | PRef FC Name -- ^ A reference to a variable

816 | PRef FC Name -- ^ A reference to a variable

808 | PInferRef FC Name -- ^ A name to be defined later

817 | PInferRef FC Name -- ^ A name to be defined later

809 | PPatvar FC Name -- ^ A pattern variable

818 | PPatvar FC Name -- ^ A pattern variable

810− | PLam FC Name PTerm PTerm -- ^ A lambda abstraction

819+ | PLam FC Name FC PTerm PTerm -- ^ A lambda abstraction. Second FC is name span.

811− | PPi Plicity Name PTerm PTerm -- ^ (n : t1) -> t2

820+ | PPi Plicity Name FC PTerm PTerm -- ^ (n : t1) -> t2, where the FC is for the precise location of the variable

812− | PLet FC Name PTerm PTerm PTerm -- ^ A let binding

821+ | PLet FC Name FC PTerm PTerm PTerm -- ^ A let binding (second FC is precise name location)

813 | PTyped PTerm PTerm -- ^ Term with explicit type

822 | PTyped PTerm PTerm -- ^ Term with explicit type

814 | PApp FC PTerm [PArg] -- ^ e.g. IO (), List Char, length x

823 | PApp FC PTerm [PArg] -- ^ e.g. IO (), List Char, length x

815 | PAppImpl PTerm [ImplicitInfo] -- ^ Implicit argument application (introduced during elaboration only)

824 | PAppImpl PTerm [ImplicitInfo] -- ^ Implicit argument application (introduced during elaboration only)

@@ -825,10 +834,10 @@ data PTerm = PQuote Raw -- ^ Inclusion of a core term into the high-level langua

825 | PAs FC Name PTerm -- ^ @-pattern, valid LHS only

834 | PAs FC Name PTerm -- ^ @-pattern, valid LHS only

826 | PAlternative Bool [PTerm] -- ^ True if only one may work. (| A, B, C|)

835 | PAlternative Bool [PTerm] -- ^ True if only one may work. (| A, B, C|)

827 | PHidden PTerm -- ^ Irrelevant or hidden pattern

836 | PHidden PTerm -- ^ Irrelevant or hidden pattern

828− | PType -- ^ 'Type' type

837+ | PType FC -- ^ 'Type' type

829 | PUniverse Universe -- ^ Some universe

838 | PUniverse Universe -- ^ Some universe

830 | PGoal FC PTerm Name PTerm -- ^ quoteGoal, used for %reflection functions

839 | PGoal FC PTerm Name PTerm -- ^ quoteGoal, used for %reflection functions

831− | PConstant Const -- ^ Builtin types

840+ | PConstant FC Const -- ^ Builtin types

832 | Placeholder -- ^ Underscore

841 | Placeholder -- ^ Underscore

833 | PDoBlock [PDo] -- ^ Do notation

842 | PDoBlock [PDo] -- ^ Do notation

834 | PIdiom FC PTerm -- ^ Idiom brackets

843 | PIdiom FC PTerm -- ^ Idiom brackets

@@ -856,9 +865,9 @@ deriving instance NFData PTerm

856

865

857mapPT :: (PTerm -> PTerm) -> PTerm -> PTerm

866mapPT :: (PTerm -> PTerm) -> PTerm -> PTerm

858mapPT f t = f (mpt t) where

867mapPT f t = f (mpt t) where

859− mpt (PLam fc n t s) = PLam fc n (mapPT f t) (mapPT f s)

868+ mpt (PLam fc n nfc t s) = PLam fc n nfc (mapPT f t) (mapPT f s)

860− mpt (PPi p n t s) = PPi p n (mapPT f t) (mapPT f s)

869+ mpt (PPi p n nfc t s) = PPi p n nfc (mapPT f t) (mapPT f s)

861− mpt (PLet fc n ty v s) = PLet fc n (mapPT f ty) (mapPT f v) (mapPT f s)

870+ mpt (PLet fc n nfc ty v s) = PLet fc n nfc (mapPT f ty) (mapPT f v) (mapPT f s)

862 mpt (PRewrite fc t s g) = PRewrite fc (mapPT f t) (mapPT f s)

871 mpt (PRewrite fc t s g) = PRewrite fc (mapPT f t) (mapPT f s)

863 (fmap (mapPT f) g)

872 (fmap (mapPT f) g)

864 mpt (PApp fc t as) = PApp fc (mapPT f t) (map (fmap (mapPT f)) as)

873 mpt (PApp fc t as) = PApp fc (mapPT f t) (map (fmap (mapPT f)) as)

@@ -945,9 +954,9 @@ instance Sized a => Sized (PTactic' a) where

945type PTactic = PTactic' PTerm

954type PTactic = PTactic' PTerm

946

955

947data PDo' t = DoExp FC t

956data PDo' t = DoExp FC t

948− | DoBind FC Name t

957+ | DoBind FC Name FC t -- ^ second FC is precise name location

949 | DoBindP FC t t [(t,t)]

958 | DoBindP FC t t [(t,t)]

950− | DoLet FC Name t t

959+ | DoLet FC Name FC t t -- ^ second FC is precise name location

951 | DoLetP FC t t

960 | DoLetP FC t t

952 deriving (Eq, Functor, Data, Typeable)

961 deriving (Eq, Functor, Data, Typeable)

953{-!

962{-!

@@ -957,9 +966,9 @@ deriving instance NFData PDo'

957

966

958instance Sized a => Sized (PDo' a) where

967instance Sized a => Sized (PDo' a) where

959 size (DoExp fc t) = 1 + size fc + size t

968 size (DoExp fc t) = 1 + size fc + size t

960− size (DoBind fc nm t) = 1 + size fc + size nm + size t

969+ size (DoBind fc nm nfc t) = 1 + size fc + size nm + size nfc + size t

961 size (DoBindP fc l r alts) = 1 + size fc + size l + size r + size alts

970 size (DoBindP fc l r alts) = 1 + size fc + size l + size r + size alts

962− size (DoLet fc nm l r) = 1 + size fc + size nm + size l + size r

971+ size (DoLet fc nm nfc l r) = 1 + size fc + size nm + size l + size r

963 size (DoLetP fc l r) = 1 + size fc + size l + size r

972 size (DoLetP fc l r) = 1 + size fc + size l + size r

964

973

965type PDo = PDo' PTerm

974type PDo = PDo' PTerm

@@ -1014,9 +1023,9 @@ highestFC (PQuote _) = Nothing

1014highestFC (PRef fc _) = Just fc

1023highestFC (PRef fc _) = Just fc

1015highestFC (PInferRef fc _) = Just fc

1024highestFC (PInferRef fc _) = Just fc

1016highestFC (PPatvar fc _) = Just fc

1025highestFC (PPatvar fc _) = Just fc

1017−highestFC (PLam fc _ _ _) = Just fc

1026+highestFC (PLam fc _ _ _ _) = Just fc

1018−highestFC (PPi _ _ _ _) = Nothing

1027+highestFC (PPi _ _ _ _ _) = Nothing

1019−highestFC (PLet fc _ _ _ _) = Just fc

1028+highestFC (PLet fc _ _ _ _ _) = Just fc

1020highestFC (PTyped tm ty) = highestFC tm <|> highestFC ty

1029highestFC (PTyped tm ty) = highestFC tm <|> highestFC ty

1021highestFC (PApp fc _ _) = Just fc

1030highestFC (PApp fc _ _) = Just fc

1022highestFC (PAppBind fc _ _) = Just fc

1031highestFC (PAppBind fc _ _) = Just fc

@@ -1034,10 +1043,10 @@ highestFC (PAlternative _ args) =

1034 [] -> Nothing

1043 [] -> Nothing

1035 (fc:_) -> Just fc

1044 (fc:_) -> Just fc

1036highestFC (PHidden _) = Nothing

1045highestFC (PHidden _) = Nothing

1037−highestFC PType = Nothing

1046+highestFC (PType fc) = Just fc

1038highestFC (PUniverse _) = Nothing

1047highestFC (PUniverse _) = Nothing

1039highestFC (PGoal fc _ _ _) = Just fc

1048highestFC (PGoal fc _ _ _) = Just fc

1040−highestFC (PConstant _) = Nothing

1049+highestFC (PConstant fc _) = Just fc

1041highestFC Placeholder = Nothing

1050highestFC Placeholder = Nothing

1042highestFC (PDoBlock lines) =

1051highestFC (PDoBlock lines) =

1043 case map getDoFC lines of

1052 case map getDoFC lines of

@@ -1045,9 +1054,9 @@ highestFC (PDoBlock lines) =

1045 (fc:_) -> Just fc

1054 (fc:_) -> Just fc

1046 where

1055 where

1047 getDoFC (DoExp fc t) = fc

1056 getDoFC (DoExp fc t) = fc

1048− getDoFC (DoBind fc nm t) = fc

1057+ getDoFC (DoBind fc nm nfc t) = fc

1049 getDoFC (DoBindP fc l r alts) = fc

1058 getDoFC (DoBindP fc l r alts) = fc

1050− getDoFC (DoLet fc nm l r) = fc

1059+ getDoFC (DoLet fc nm nfc l r) = fc

1051 getDoFC (DoLetP fc l r) = fc

1060 getDoFC (DoLetP fc l r) = fc

1052

1061

1053highestFC (PIdiom fc _) = Just fc

1062highestFC (PIdiom fc _) = Just fc

@@ -1252,10 +1261,10 @@ bi = fileFC "builtin"

1252

1261

1253inferTy = sMN 0 "__Infer"

1262inferTy = sMN 0 "__Infer"

1254inferCon = sMN 0 "__infer"

1263inferCon = sMN 0 "__infer"

1255−inferDecl = PDatadecl inferTy

1264+inferDecl = PDatadecl inferTy NoFC

1256− PType

1265+ (PType bi)

1257− [(emptyDocstring, [], inferCon, PPi impl (sMN 0 "iType") PType (

1266+ [(emptyDocstring, [], inferCon, NoFC, PPi impl (sMN 0 "iType") NoFC (PType bi) (

1258− PPi expl (sMN 0 "ival") (PRef bi (sMN 0 "iType"))

1267+ PPi expl (sMN 0 "ival") NoFC (PRef bi (sMN 0 "iType"))

1259 (PRef bi inferTy)), bi, [])]

1268 (PRef bi inferTy)), bi, [])]

1260inferOpts = []

1269inferOpts = []

1261

1270

@@ -1309,16 +1318,16 @@ eqDoc = fmap (const (Left $ Msg "")) . parseDocstring . T.pack $

1309 "\n\n" ++

1318 "\n\n" ++

1310 "You may need to use `(~=~)` to explicitly request heterogeneous equality."

1319 "You may need to use `(~=~)` to explicitly request heterogeneous equality."

1311

1320

1312−eqDecl = PDatadecl eqTy (piBindp impl [(n "A", PType), (n "B", PType)]

1321+eqDecl = PDatadecl eqTy NoFC (piBindp impl [(n "A", PType bi), (n "B", PType bi)]

1313− (piBind [(n "x", PRef bi (n "A")), (n "y", PRef bi (n "B"))]

1322+ (piBind [(n "x", PRef bi (n "A")), (n "y", PRef bi (n "B"))]

1314− PType))

1323+ (PType bi)))

1315 [(reflDoc, reflParamDoc,

1324 [(reflDoc, reflParamDoc,

1316− eqCon, PPi impl (n "A") PType (

1325+ eqCon, NoFC, PPi impl (n "A") NoFC (PType bi) (

1317− PPi impl (n "x") (PRef bi (n "A"))

1326+ PPi impl (n "x") NoFC (PRef bi (n "A"))

1318− (PApp bi (PRef bi eqTy) [pimp (n "A") Placeholder False,

1327+ (PApp bi (PRef bi eqTy) [pimp (n "A") Placeholder False,

1319− pimp (n "B") Placeholder False,

1328+ pimp (n "B") Placeholder False,

1320− pexp (PRef bi (n "x")),

1329+ pexp (PRef bi (n "x")),

1321− pexp (PRef bi (n "x"))])), bi, [])]

1330+ pexp (PRef bi (n "x"))])), bi, [])]

1322 where n a = sUN a

1331 where n a = sUN a

1323 reflDoc = annotCode (const (Left $ Msg "")) . parseDocstring . T.pack $

1332 reflDoc = annotCode (const (Left $ Msg "")) . parseDocstring . T.pack $

1324 "A proof that `x` in fact equals `x`. To construct this, you must have already " ++

1333 "A proof that `x` in fact equals `x`. To construct this, you must have already " ++

@@ -1348,7 +1357,7 @@ piBind = piBindp expl

1348

1357

1349piBindp :: Plicity -> [(Name, PTerm)] -> PTerm -> PTerm

1358piBindp :: Plicity -> [(Name, PTerm)] -> PTerm -> PTerm

1350piBindp p [] t = t

1359piBindp p [] t = t

1351−piBindp p ((n, ty):ns) t = PPi p n ty (piBindp p ns t)

1360+piBindp p ((n, ty):ns) t = PPi p n NoFC ty (piBindp p ns t)

1352

1361

1353

1362

1354-- Pretty-printing declarations and terms

1363-- Pretty-printing declarations and terms

@@ -1437,15 +1446,15 @@ pprintPTerm ppo bnd docArgs infixes = prettySe startPrec bnd

1437 | Just str <- slist p bnd e = str

1446 | Just str <- slist p bnd e = str

1438 | Just n <- snat p e = annotate (AnnData "Nat" "") (text (show n))

1447 | Just n <- snat p e = annotate (AnnData "Nat" "") (text (show n))

1439 prettySe p bnd (PRef fc n) = prettyName True (ppopt_impl ppo) bnd n

1448 prettySe p bnd (PRef fc n) = prettyName True (ppopt_impl ppo) bnd n

1440− prettySe p bnd (PLam fc n ty sc) =

1449+ prettySe p bnd (PLam fc n nfc ty sc) =

1441 bracket p startPrec . group . align . hang 2 $

1450 bracket p startPrec . group . align . hang 2 $

1442 text "\\" <> prettyBindingOf n False <+> text "=>" <$>

1451 text "\\" <> prettyBindingOf n False <+> text "=>" <$>

1443 prettySe startPrec ((n, False):bnd) sc

1452 prettySe startPrec ((n, False):bnd) sc

1444− prettySe p bnd (PLet fc n ty v sc) =

1453+ prettySe p bnd (PLet fc n nfc ty v sc) =

1445 bracket p startPrec . group . align $

1454 bracket p startPrec . group . align $

1446 kwd "let" <+> (group . align . hang 2 $ prettyBindingOf n False <+> text "=" <$> prettySe startPrec bnd v) </>

1455 kwd "let" <+> (group . align . hang 2 $ prettyBindingOf n False <+> text "=" <$> prettySe startPrec bnd v) </>

1447 kwd "in" <+> (group . align . hang 2 $ prettySe startPrec ((n, False):bnd) sc)

1456 kwd "in" <+> (group . align . hang 2 $ prettySe startPrec ((n, False):bnd) sc)

1448− prettySe p bnd (PPi (Exp l s _) n ty sc)

1457+ prettySe p bnd (PPi (Exp l s _) n _ ty sc)

1449 | n `elem` allNamesIn sc || ppopt_impl ppo || n `elem` docArgs =

1458 | n `elem` allNamesIn sc || ppopt_impl ppo || n `elem` docArgs =

1450 bracket p startPrec . group $

1459 bracket p startPrec . group $

1451 enclose lparen rparen (group . align $ prettyBindingOf n False <+> colon <+> prettySe startPrec bnd ty) <+>

1460 enclose lparen rparen (group . align $ prettyBindingOf n False <+> colon <+> prettySe startPrec bnd ty) <+>

@@ -1458,7 +1467,7 @@ pprintPTerm ppo bnd docArgs infixes = prettySe startPrec bnd

1458 case s of

1467 case s of

1459 Static -> text "[static]" <> space

1468 Static -> text "[static]" <> space

1460 _ -> empty

1469 _ -> empty

1461− prettySe p bnd (PPi (Imp l s _ fa) n ty sc)

1470+ prettySe p bnd (PPi (Imp l s _ fa) n _ ty sc)

1462 | ppopt_impl ppo =

1471 | ppopt_impl ppo =

1463 bracket p startPrec $

1472 bracket p startPrec $

1464 lbrace <> prettyBindingOf n True <+> colon <+> prettySe startPrec bnd ty <> rbrace <+>

1473 lbrace <> prettyBindingOf n True <+> colon <+> prettySe startPrec bnd ty <> rbrace <+>

@@ -1469,10 +1478,10 @@ pprintPTerm ppo bnd docArgs infixes = prettySe startPrec bnd

1469 case s of

1478 case s of

1470 Static -> text "[static]" <> space

1479 Static -> text "[static]" <> space

1471 _ -> empty

1480 _ -> empty

1472− prettySe p bnd (PPi (Constraint _ _) n ty sc) =

1481+ prettySe p bnd (PPi (Constraint _ _) n _ ty sc) =

1473 bracket p startPrec $

1482 bracket p startPrec $

1474 prettySe (startPrec + 1) bnd ty <+> text "=>" </> prettySe startPrec ((n, True):bnd) sc

1483 prettySe (startPrec + 1) bnd ty <+> text "=>" </> prettySe startPrec ((n, True):bnd) sc

1475− prettySe p bnd (PPi (TacImp _ _ s) n ty sc) =

1484+ prettySe p bnd (PPi (TacImp _ _ s) n _ ty sc) =

1476 bracket p startPrec $

1485 bracket p startPrec $

1477 lbrace <> kwd "tacimp" <+> pretty n <+> colon <+> prettySe startPrec bnd ty <>

1486 lbrace <> kwd "tacimp" <+> pretty n <+> colon <+> prettySe startPrec bnd ty <>

1478 rbrace <+> text "->" </> prettySe startPrec ((n, True):bnd) sc

1487 rbrace <+> text "->" </> prettySe startPrec ((n, True):bnd) sc

@@ -1525,7 +1534,7 @@ pprintPTerm ppo bnd docArgs infixes = prettySe startPrec bnd

1525 (prettySe left bnd l <+> opName False) <$>

1534 (prettySe left bnd l <+> opName False) <$>

1526 group (prettySe right bnd r)

1535 group (prettySe right bnd r)

1527 prettySe p bnd (PApp _ hd@(PRef fc f) [tm]) -- symbols, like 'foo

1536 prettySe p bnd (PApp _ hd@(PRef fc f) [tm]) -- symbols, like 'foo

1528− | PConstant (Idris.Core.TT.Str str) <- getTm tm,

1537+ | PConstant NoFC (Idris.Core.TT.Str str) <- getTm tm,

1529 f == sUN "Symbol_" = annotate (AnnType ("'" ++ str) ("The symbol " ++ str)) $

1538 f == sUN "Symbol_" = annotate (AnnType ("'" ++ str) ("The symbol " ++ str)) $

1530 char '\'' <> prettySe startPrec bnd (PRef fc (sUN str))

1539 char '\'' <> prettySe startPrec bnd (PRef fc (sUN str))

1531 prettySe p bnd (PApp _ f as) = -- Normal prefix applications

1540 prettySe p bnd (PApp _ f as) = -- Normal prefix applications

@@ -1601,9 +1610,9 @@ pprintPTerm ppo bnd docArgs infixes = prettySe startPrec bnd

1601 where

1610 where

1602 prettyAs =

1611 prettyAs =

1603 foldr (\l -> \r -> l <+> text "," <+> r) empty $ map (prettySe startPrec bnd) as

1612 foldr (\l -> \r -> l <+> text "," <+> r) empty $ map (prettySe startPrec bnd) as

1604− prettySe p bnd PType = annotate (AnnType "Type" "The type of types") $ text "Type"

1613+ prettySe p bnd (PType _) = annotate (AnnType "Type" "The type of types") $ text "Type"

1605 prettySe p bnd (PUniverse u) = annotate (AnnType (show u) "The type of unique types") $ text (show u)

1614 prettySe p bnd (PUniverse u) = annotate (AnnType (show u) "The type of unique types") $ text (show u)

1606− prettySe p bnd (PConstant c) = annotate (AnnConst c) (text (show c))

1615+ prettySe p bnd (PConstant _ c) = annotate (AnnConst c) (text (show c))

1607 -- XXX: add pretty for tactics

1616 -- XXX: add pretty for tactics

1608 prettySe p bnd (PProof ts) =

1617 prettySe p bnd (PProof ts) =

1609 text "proof" <+> lbrace <> nest nestingSize (text . show $ ts) <> rbrace

1618 text "proof" <+> lbrace <> nest nestingSize (text . show $ ts) <> rbrace

@@ -1763,24 +1772,24 @@ showCImp ppo (PWith _ n l ws r pn w)

1763

1772

1764

1773

1765showDImp :: PPOption -> PData -> Doc OutputAnnotation

1774showDImp :: PPOption -> PData -> Doc OutputAnnotation

1766−showDImp ppo (PDatadecl n ty cons)

1775+showDImp ppo (PDatadecl n nfc ty cons)

1767 = text "data" <+> text (show n) <+> colon <+> prettyImp ppo ty <+> text "where" <$>

1776 = text "data" <+> text (show n) <+> colon <+> prettyImp ppo ty <+> text "where" <$>

1768− (indent 2 $ vsep (map (\ (_, _, n, t, _, _) -> pipe <+> prettyName True False [] n <+> colon <+> prettyImp ppo t) cons))

1777+ (indent 2 $ vsep (map (\ (_, _, n, _, t, _, _) -> pipe <+> prettyName True False [] n <+> colon <+> prettyImp ppo t) cons))

1769

1778

1770showDecls :: PPOption -> [PDecl] -> Doc OutputAnnotation

1779showDecls :: PPOption -> [PDecl] -> Doc OutputAnnotation

1771showDecls o ds = vsep (map (showDeclImp o) ds)

1780showDecls o ds = vsep (map (showDeclImp o) ds)

1772

1781

1773showDeclImp _ (PFix _ f ops) = text (show f) <+> cat (punctuate (text ",") (map text ops))

1782showDeclImp _ (PFix _ f ops) = text (show f) <+> cat (punctuate (text ",") (map text ops))

1774−showDeclImp o (PTy _ _ _ _ _ n t) = text "tydecl" <+> text (showCG n) <+> colon <+> prettyImp o t

1783+showDeclImp o (PTy _ _ _ _ _ n _ t) = text "tydecl" <+> text (showCG n) <+> colon <+> prettyImp o t

1775showDeclImp o (PClauses _ _ n cs) = text "pat" <+> text (showCG n) <+> text "\t" <+>

1784showDeclImp o (PClauses _ _ n cs) = text "pat" <+> text (showCG n) <+> text "\t" <+>

1776 indent 2 (vsep (map (showCImp o) cs))

1785 indent 2 (vsep (map (showCImp o) cs))

1777showDeclImp o (PData _ _ _ _ _ d) = showDImp o { ppopt_impl = True } d

1786showDeclImp o (PData _ _ _ _ _ d) = showDImp o { ppopt_impl = True } d

1778showDeclImp o (PParams _ ns ps) = text "params" <+> braces (text (show ns) <> line <> showDecls o ps <> line)

1787showDeclImp o (PParams _ ns ps) = text "params" <+> braces (text (show ns) <> line <> showDecls o ps <> line)

1779showDeclImp o (PNamespace n ps) = text "namespace" <+> text n <> braces (line <> showDecls o ps <> line)

1788showDeclImp o (PNamespace n ps) = text "namespace" <+> text n <> braces (line <> showDecls o ps <> line)

1780showDeclImp _ (PSyntax _ syn) = text "syntax" <+> text (show syn)

1789showDeclImp _ (PSyntax _ syn) = text "syntax" <+> text (show syn)

1781−showDeclImp o (PClass _ _ _ cs n ps _ _ ds _ _)

1790+showDeclImp o (PClass _ _ _ cs n _ ps _ _ ds _ _)

1782 = text "class" <+> text (show cs) <+> text (show n) <+> text (show ps) <> line <> showDecls o ds

1791 = text "class" <+> text (show cs) <+> text (show n) <+> text (show ps) <> line <> showDecls o ds

1783−showDeclImp o (PInstance _ _ _ _ cs n _ t _ ds)

1792+showDeclImp o (PInstance _ _ _ _ cs n _ _ t _ ds)

1784 = text "instance" <+> text (show cs) <+> text (show n) <+> prettyImp o t <> line <> showDecls o ds

1793 = text "instance" <+> text (show cs) <+> text (show n) <+> prettyImp o t <> line <> showDecls o ds

1785showDeclImp _ _ = text "..."

1794showDeclImp _ _ = text "..."

1786-- showDeclImp (PImport o) = "import " ++ o

1795-- showDeclImp (PImport o) = "import " ++ o

@@ -1857,9 +1866,9 @@ showTmImpls = flip (displayS . renderCompact . prettyImp verbosePPOption) ""

1857instance Sized PTerm where

1866instance Sized PTerm where

1858 size (PQuote rawTerm) = size rawTerm

1867 size (PQuote rawTerm) = size rawTerm

1859 size (PRef fc name) = size name

1868 size (PRef fc name) = size name

1860− size (PLam fc name ty bdy) = 1 + size ty + size bdy

1869+ size (PLam fc name _ ty bdy) = 1 + size ty + size bdy

1861− size (PPi plicity name ty bdy) = 1 + size ty + size bdy

1870+ size (PPi plicity name fc ty bdy) = 1 + size ty + size fc + size bdy

1862− size (PLet fc name ty def bdy) = 1 + size ty + size def + size bdy

1871+ size (PLet fc name nfc ty def bdy) = 1 + size ty + size def + size bdy

1863 size (PTyped trm ty) = 1 + size trm + size ty

1872 size (PTyped trm ty) = 1 + size trm + size ty

1864 size (PApp fc name args) = 1 + size args

1873 size (PApp fc name args) = 1 + size args

1865 size (PAppBind fc name args) = 1 + size args

1874 size (PAppBind fc name args) = 1 + size args

@@ -1875,9 +1884,9 @@ instance Sized PTerm where

1875 size (PUnifyLog tm) = size tm

1884 size (PUnifyLog tm) = size tm

1876 size (PDisamb _ tm) = size tm

1885 size (PDisamb _ tm) = size tm

1877 size (PNoImplicits tm) = size tm

1886 size (PNoImplicits tm) = size tm

1878− size PType = 1

1887+ size (PType _) = 1

1879 size (PUniverse _) = 1

1888 size (PUniverse _) = 1

1880− size (PConstant const) = 1 + size const

1889+ size (PConstant fc const) = 1 + size fc + size const

1881 size Placeholder = 1

1890 size Placeholder = 1

1882 size (PDoBlock dos) = 1 + size dos

1891 size (PDoBlock dos) = 1 + size dos

1883 size (PIdiom fc term) = 1 + size term

1892 size (PIdiom fc term) = 1 + size term

@@ -1889,7 +1898,7 @@ instance Sized PTerm where

1889 size _ = 0

1898 size _ = 0

1890

1899

1891getPArity :: PTerm -> Int

1900getPArity :: PTerm -> Int

1892−getPArity (PPi _ _ _ sc) = 1 + getPArity sc

1901+getPArity (PPi _ _ _ _ sc) = 1 + getPArity sc

1893getPArity _ = 0

1902getPArity _ = 0

1894

1903

1895-- Return all names, free or globally bound, in the given term.

1904-- Return all names, free or globally bound, in the given term.

@@ -1904,8 +1913,8 @@ allNamesIn tm = nub $ ni [] tm

1904 ni env (PAppBind _ f as) = ni env f ++ concatMap (ni env) (map getTm as)

1913 ni env (PAppBind _ f as) = ni env f ++ concatMap (ni env) (map getTm as)

1905 ni env (PCase _ c os) = ni env c ++ concatMap (ni env) (map snd os)

1914 ni env (PCase _ c os) = ni env c ++ concatMap (ni env) (map snd os)

1906 ni env (PIfThenElse _ c t f) = ni env c ++ ni env t ++ ni env f

1915 ni env (PIfThenElse _ c t f) = ni env c ++ ni env t ++ ni env f

1907− ni env (PLam fc n ty sc) = ni env ty ++ ni (n:env) sc

1916+ ni env (PLam fc n _ ty sc) = ni env ty ++ ni (n:env) sc

1908− ni env (PPi p n ty sc) = niTacImp env p ++ ni env ty ++ ni (n:env) sc

1917+ ni env (PPi p n _ ty sc) = niTacImp env p ++ ni env ty ++ ni (n:env) sc

1909 ni env (PHidden tm) = ni env tm

1918 ni env (PHidden tm) = ni env tm

1910 ni env (PRewrite _ l r _) = ni env l ++ ni env r

1919 ni env (PRewrite _ l r _) = ni env l ++ ni env r

1911 ni env (PTyped l r) = ni env l ++ ni env r

1920 ni env (PTyped l r) = ni env l ++ ni env r

@@ -1930,9 +1939,9 @@ boundNamesIn tm = S.toList (ni S.empty tm)

1930 ni set (PAppBind _ f as) = niTms (ni set f) (map getTm as)

1939 ni set (PAppBind _ f as) = niTms (ni set f) (map getTm as)

1931 ni set (PCase _ c os) = niTms (ni set c) (map snd os)

1940 ni set (PCase _ c os) = niTms (ni set c) (map snd os)

1932 ni set (PIfThenElse _ c t f) = niTms set [c, t, f]

1941 ni set (PIfThenElse _ c t f) = niTms set [c, t, f]

1933− ni set (PLam fc n ty sc) = S.insert n $ ni (ni set ty) sc

1942+ ni set (PLam fc n _ ty sc) = S.insert n $ ni (ni set ty) sc

1934− ni set (PLet fc n ty val sc) = S.insert n $ ni (ni (ni set ty) val) sc

1943+ ni set (PLet fc n nfc ty val sc) = S.insert n $ ni (ni (ni set ty) val) sc

1935− ni set (PPi p n ty sc) = niTacImp (S.insert n $ ni (ni set ty) sc) p

1944+ ni set (PPi p n _ ty sc) = niTacImp (S.insert n $ ni (ni set ty) sc) p

1936 ni set (PRewrite _ l r _) = ni (ni set l) r

1945 ni set (PRewrite _ l r _) = ni (ni set l) r

1937 ni set (PTyped l r) = ni (ni set l) r

1946 ni set (PTyped l r) = ni (ni set l) r

1938 ni set (PPair _ _ l r) = ni (ni set l) r

1947 ni set (PPair _ _ l r) = ni (ni set l) r

@@ -1970,8 +1979,8 @@ implicitNamesIn uvars ist tm = nub $ ni [] tm

1970 (nub (concatMap (ni env) (map snd os))

1979 (nub (concatMap (ni env) (map snd os))

1971 \\ nub (concatMap (ni env) (map fst os)))

1980 \\ nub (concatMap (ni env) (map fst os)))

1972 ni env (PIfThenElse _ c t f) = concatMap (ni env) [c, t, f]

1981 ni env (PIfThenElse _ c t f) = concatMap (ni env) [c, t, f]

1973− ni env (PLam fc n ty sc) = ni env ty ++ ni (n:env) sc

1982+ ni env (PLam fc n _ ty sc) = ni env ty ++ ni (n:env) sc

1974− ni env (PPi p n ty sc) = ni env ty ++ ni (n:env) sc

1983+ ni env (PPi p n _ ty sc) = ni env ty ++ ni (n:env) sc

1975 ni env (PRewrite _ l r _) = ni env l ++ ni env r

1984 ni env (PRewrite _ l r _) = ni env l ++ ni env r

1976 ni env (PTyped l r) = ni env l ++ ni env r

1985 ni env (PTyped l r) = ni env l ++ ni env r

1977 ni env (PPair _ _ l r) = ni env l ++ ni env r

1986 ni env (PPair _ _ l r) = ni env l ++ ni env r

@@ -2000,8 +2009,8 @@ namesIn uvars ist tm = nub $ ni [] tm

2000 (nub (concatMap (ni env) (map snd os))

2009 (nub (concatMap (ni env) (map snd os))

2001 \\ nub (concatMap (ni env) (map fst os)))

2010 \\ nub (concatMap (ni env) (map fst os)))

2002 ni env (PIfThenElse _ c t f) = concatMap (ni env) [c, t, f]

2011 ni env (PIfThenElse _ c t f) = concatMap (ni env) [c, t, f]

2003− ni env (PLam fc n ty sc) = ni env ty ++ ni (n:env) sc

2012+ ni env (PLam fc n nfc ty sc) = ni env ty ++ ni (n:env) sc

2004− ni env (PPi p n ty sc) = niTacImp env p ++ ni env ty ++ ni (n:env) sc

2013+ ni env (PPi p n _ ty sc) = niTacImp env p ++ ni env ty ++ ni (n:env) sc

2005 ni env (PRewrite _ l r _) = ni env l ++ ni env r

2014 ni env (PRewrite _ l r _) = ni env l ++ ni env r

2006 ni env (PTyped l r) = ni env l ++ ni env r

2015 ni env (PTyped l r) = ni env l ++ ni env r

2007 ni env (PPair _ _ l r) = ni env l ++ ni env r

2016 ni env (PPair _ _ l r) = ni env l ++ ni env r

@@ -2031,8 +2040,8 @@ usedNamesIn vars ist tm = nub $ ni [] tm

2031 ni env (PAppBind _ f as) = ni env f ++ concatMap (ni env) (map getTm as)

2040 ni env (PAppBind _ f as) = ni env f ++ concatMap (ni env) (map getTm as)

2032 ni env (PCase _ c os) = ni env c ++ concatMap (ni env) (map snd os)

2041 ni env (PCase _ c os) = ni env c ++ concatMap (ni env) (map snd os)

2033 ni env (PIfThenElse _ c t f) = concatMap (ni env) [c, t, f]

2042 ni env (PIfThenElse _ c t f) = concatMap (ni env) [c, t, f]

2034− ni env (PLam fc n ty sc) = ni env ty ++ ni (n:env) sc

2043+ ni env (PLam fc n _ ty sc) = ni env ty ++ ni (n:env) sc

2035− ni env (PPi p n ty sc) = niTacImp env p ++ ni env ty ++ ni (n:env) sc

2044+ ni env (PPi p n _ ty sc) = niTacImp env p ++ ni env ty ++ ni (n:env) sc

2036 ni env (PRewrite _ l r _) = ni env l ++ ni env r

2045 ni env (PRewrite _ l r _) = ni env l ++ ni env r

2037 ni env (PTyped l r) = ni env l ++ ni env r

2046 ni env (PTyped l r) = ni env l ++ ni env r

2038 ni env (PPair _ _ l r) = ni env l ++ ni env r

2047 ni env (PPair _ _ l r) = ni env l ++ ni env r

src/Idris/CaseSplit.hs+6−6

@@ -345,19 +345,19 @@ getClause l fn fp

345 return (show fn ++ " " ++ ap ++ "= ?"

346 ++ show fn ++ "_rhs")

347 where mkApp :: IState -> PTerm -> [Name] -> String

348− mkApp i (PPi (Exp _ _ False) (MN _ _) ty sc) used

348+ mkApp i (PPi (Exp _ _ False) (MN _ _) _ ty sc) used

349 = let n = getNameFrom i used ty in

350 show n ++ " " ++ mkApp i sc (n : used)

351− mkApp i (PPi (Exp _ _ False) (UN n) ty sc) used

351+ mkApp i (PPi (Exp _ _ False) (UN n) _ ty sc) used

352 | thead n == '_'

353 = let n = getNameFrom i used ty in

354 show n ++ " " ++ mkApp i sc (n : used)

355− mkApp i (PPi (Exp _ _ False) n _ sc) used

355+ mkApp i (PPi (Exp _ _ False) n _ _ sc) used

356 = show n ++ " " ++ mkApp i sc (n : used)

357− mkApp i (PPi _ _ _ sc) used = mkApp i sc used

357+ mkApp i (PPi _ _ _ _ sc) used = mkApp i sc used

358 mkApp i _ _ = ""

359

360− getNameFrom i used (PPi _ _ _ _)

360+ getNameFrom i used (PPi _ _ _ _ _)

361 = uniqueNameFrom (mkSupply [sUN "f", sUN "g"]) used

362 getNameFrom i used (PApp fc f as) = getNameFrom i used f

363 getNameFrom i used (PRef fc f)

@@ -386,7 +386,7 @@ getProofClause :: Int -- ^ line number that the type is declared

386getProofClause l fn fp

387 = do ty <- getInternalApp fp l

388 return (mkApp ty ++ " = ?" ++ show fn ++ "_rhs")

389− where mkApp (PPi _ _ _ sc) = mkApp sc

389+ where mkApp (PPi _ _ _ _ sc) = mkApp sc

390 mkApp rt = "(" ++ show rt ++ ") <== " ++ show fn

391

392-- Purely syntactic - turn a pattern match clause into a with and a new

src/Idris/Core/Binary.hs+19−8

@@ -249,15 +249,26 @@ instance Binary a => Binary (Err' a) where

249----- Generated by 'derive'

250

251instance Binary FC where

252− put (FC x1 (x2, x3) (x4, x5))

252+ put x =

253+ case x of

254+ (FC x1 (x2, x3) (x4, x5)) -> do putWord8 0

253− = do put x1

255+ put x1

254− put (x2 * 65536 + x3)

256+ put (x2 * 65536 + x3)

255− put (x4 * 65536 + x5)

257+ put (x4 * 65536 + x5)

258+ NoFC -> putWord8 1

259+ FileFC x1 -> do putWord8 2

260+ put x1

256 get

261 get

262+ = do i <- getWord8

263+ case i of

257− = do x1 <- get

264+ 0 -> do x1 <- get

258− x2x3 <- get

265+ x2x3 <- get

259− x4x5 <- get

266+ x4x5 <- get

260− return (FC x1 (x2x3 `div` 65536, x2x3 `mod` 65536) (x4x5 `div` 65536, x4x5 `mod` 65536))

267+ return (FC x1 (x2x3 `div` 65536, x2x3 `mod` 65536) (x4x5 `div` 65536, x4x5 `mod` 65536))

268+ 1 -> return NoFC

269+ 2 -> do x1 <- get

270+ return (FileFC x1)

271+ _ -> error "Corrupted binary data for FC"

261

272

262

273

263instance Binary Name where

274instance Binary Name where

src/Idris/Core/DeepSeq.hs+2

@@ -43,6 +43,8 @@ instance NFData Raw where

44instance NFData FC where

45 rnf (FC x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

46+ rnf NoFC = ()

47+ rnf (FileFC f) = rnf f `seq` ()

47instance NFData Provenance where

49instance NFData Provenance where

48 rnf ExpectedType = ()

50 rnf ExpectedType = ()

src/Idris/Core/TT.hs+65−9

@@ -49,11 +49,59 @@ data Option = TTypeInTType

49 deriving Eq

51-- | Source location. These are typically produced by the parser 'Idris.Parser.getFC'

52−data FC = FC { fc_fname :: String, -- ^ Filename

52+data FC = FC { _fc_fname :: String, -- ^ Filename

53− fc_start :: (Int, Int), -- ^ Line and column numbers for the start of the location span

53+ _fc_start :: (Int, Int), -- ^ Line and column numbers for the start of the location span

54− fc_end :: (Int, Int) -- ^ Line and column numbers for the end of the location span

54+ _fc_end :: (Int, Int) -- ^ Line and column numbers for the end of the location span

55 }

56+ | NoFC -- ^ Locations for machine-generated terms

57+ | FileFC { _fc_fname :: String } -- ^ Locations with file only

56− deriving (Data, Typeable, Ord)

58+ deriving (Data, Typeable, Ord)

59+

60+-- TODO: find uses and destroy them, doing this case analysis at call sites

61+-- | Give a notion of filename associated with an FC

62+fc_fname :: FC -> String

63+fc_fname (FC f _ _) = f

64+fc_fname NoFC = "(no file)"

65+fc_fname (FileFC f) = f

66+

67+-- TODO: find uses and destroy them, doing this case analysis at call sites

68+-- | Give a notion of start location associated with an FC

69+fc_start :: FC -> (Int, Int)

70+fc_start (FC _ start _) = start

71+fc_start NoFC = (0, 0)

72+fc_start (FileFC f) = (0, 0)

73+

74+-- TODO: find uses and destroy them, doing this case analysis at call sites

75+-- | Give a notion of end location associated with an FC

76+fc_end :: FC -> (Int, Int)

77+fc_end (FC _ _ end) = end

78+fc_end NoFC = (0, 0)

79+fc_end (FileFC f) = (0, 0)

80+

81+-- | Get the largest span containing the two FCs

82+spanFC :: FC -> FC -> FC

83+spanFC (FC f start end) (FC f' start' end')

84+ | f == f' = FC f (minLocation start start') (maxLocation end end')

85+ | otherwise = NoFC

86+ where minLocation (l, c) (l', c') =

87+ case compare l l' of

88+ LT -> (l, c)

89+ EQ -> (l, min c c')

90+ GT -> (l', c')

91+ maxLocation (l, c) (l', c') =

92+ case compare l l' of

93+ LT -> (l', c')

94+ EQ -> (l, max c c')

95+ GT -> (l, c)

96+spanFC fc@(FC f _ _) (FileFC f') | f == f' = fc

97+ | otherwise = NoFC

98+spanFC (FileFC f') fc@(FC f _ _) | f == f' = fc

99+ | otherwise = NoFC

100+spanFC (FileFC f) (FileFC f') | f == f' = FileFC f

101+ | otherwise = NoFC

102+spanFC NoFC fc = fc

103+spanFC fc NoFC = fc

104+

105

58-- | Ignore source location equality (so deriving classes do not compare FCs)

106-- | Ignore source location equality (so deriving classes do not compare FCs)

59instance Eq FC where

107instance Eq FC where

@@ -65,14 +113,17 @@ newtype FC' = FC' { unwrapFC :: FC }

65instance Eq FC' where

113instance Eq FC' where

66 FC' fc == FC' fc' = fcEq fc fc'

114 FC' fc == FC' fc' = fcEq fc fc'

67 where fcEq (FC n s e) (FC n' s' e') = n == n' && s == s' && e == e'

115 where fcEq (FC n s e) (FC n' s' e') = n == n' && s == s' && e == e'

116+ fcEq NoFC NoFC = True

117+ fcEq (FileFC f) (FileFC f') = f == f'

118+ fcEq _ _ = False

119

69-- | Empty source location

120-- | Empty source location

70emptyFC :: FC

121emptyFC :: FC

71−emptyFC = fileFC ""

122+emptyFC = NoFC

123

73−-- | Source location with file only

124+-- | Source location with file only

74fileFC :: String -> FC

125fileFC :: String -> FC

75−fileFC s = FC s (0, 0) (0, 0)

126+fileFC s = FileFC s

127

77{-!

128{-!

78deriving instance Binary FC

129deriving instance Binary FC

@@ -81,18 +132,22 @@ deriving instance NFData FC

132

82instance Sized FC where

133instance Sized FC where

83 size (FC f s e) = 4 + length f

134 size (FC f s e) = 4 + length f

135+ size NoFC = 1

136+ size (FileFC f) = length f

137

85instance Show FC where

138instance Show FC where

86 show (FC f s e) = f ++ ":" ++ showLC s e

139 show (FC f s e) = f ++ ":" ++ showLC s e

87 where showLC (sl, sc) (el, ec) | sl == el && sc == ec = show sl ++ ":" ++ show sc

140 where showLC (sl, sc) (el, ec) | sl == el && sc == ec = show sl ++ ":" ++ show sc

88 | sl == el = show sl ++ ":" ++ show sc ++ "-" ++ show ec

141 | sl == el = show sl ++ ":" ++ show sc ++ "-" ++ show ec

89 | otherwise = show sl ++ ":" ++ show sc ++ "-" ++ show el ++ ":" ++ show ec

142 | otherwise = show sl ++ ":" ++ show sc ++ "-" ++ show el ++ ":" ++ show ec

143+ show NoFC = "No location"

144+ show (FileFC f) = f

145

91-- | Output annotation for pretty-printed name - decides colour

146-- | Output annotation for pretty-printed name - decides colour

92−data NameOutput = TypeOutput | FunOutput | DataOutput | MetavarOutput | PostulateOutput

147+data NameOutput = TypeOutput | FunOutput | DataOutput | MetavarOutput | PostulateOutput deriving Show

148

94-- | Text formatting output

149-- | Text formatting output

95−data TextFormatting = BoldText | ItalicText | UnderlineText

150+data TextFormatting = BoldText | ItalicText | UnderlineText deriving Show

151

97-- | Output annotations for pretty-printing

152-- | Output annotations for pretty-printing

98data OutputAnnotation = AnnName Name (Maybe NameOutput) (Maybe String) (Maybe String)

153data OutputAnnotation = AnnName Name (Maybe NameOutput) (Maybe String) (Maybe String)

@@ -108,6 +163,7 @@ data OutputAnnotation = AnnName Name (Maybe NameOutput) (Maybe String) (Maybe St

108 | AnnTerm [(Name, Bool)] (TT Name) -- ^ pprint bound vars, original term

163 | AnnTerm [(Name, Bool)] (TT Name) -- ^ pprint bound vars, original term

109 | AnnSearchResult Ordering -- ^ more general, isomorphic, or more specific

164 | AnnSearchResult Ordering -- ^ more general, isomorphic, or more specific

110 | AnnErr Err

165 | AnnErr Err

166+ deriving Show

111

167

112-- | Used for error reflection

168-- | Used for error reflection

113data ErrorReportPart = TextPart String

169data ErrorReportPart = TextPart String

src/Idris/Coverage.hs+4−4

@@ -179,8 +179,8 @@ genAll i args

179 where

180 -- if they're constants, invent a new one to make sure that

181 -- constants which are not explicitly handled are covered

182− inventConsts cs@(PConstant c : _) = map PConstant (ic' (mapMaybe getConst cs))

182+ inventConsts cs@(PConstant fc c : _) = map (PConstant NoFC) (ic' (mapMaybe getConst cs))

183− where getConst (PConstant c) = Just c

183+ where getConst (PConstant _ c) = Just c

184 getConst _ = Nothing

185 inventConsts xs = xs

186

@@ -226,7 +226,7 @@ genAll i args

226 ([pimp (sUN "a") Placeholder True,

227 pimp (sUN "P") Placeholder True] ++

228 [pexp t,pexp v]) o

229− otherPats o@(PConstant c) = inventConsts [o] -- return o

229+ otherPats o@(PConstant _ c) = inventConsts [o] -- return o

230 otherPats arg = return Placeholder

231

232 ops fc n xs o

@@ -278,7 +278,7 @@ genAll i args

278

279 -- quick check for constructor equality

280 quickEq :: PTerm -> PTerm -> Bool

281− quickEq (PConstant n) (PConstant n') = n == n'

281+ quickEq (PConstant _ n) (PConstant _ n') = n == n'

282 quickEq (PRef _ n) (PRef _ n') = n == n'

283 quickEq (PApp _ t as) (PApp _ t' as')

284 | length as == length as'

src/Idris/DSL.hs+28−28

@@ -33,8 +33,8 @@ mkTTName fc n =

33 mkList fc (x:xs) = PApp fc (PRef fc (sNS (sUN "::") ["List", "Prelude"]))

34 [ pexp (stringC x)

35 , pexp (mkList fc xs)]

36− stringC = PConstant . Str . str

36+ stringC = PConstant fc . Str . str

37− intC = PConstant . I

37+ intC = PConstant fc . I

38 reflm n = sNS (sUN n) ["Reflection", "Language"]

39 in case n of

40 UN nm -> PApp fc (PRef fc (reflm "UN")) [ pexp (stringC nm)]

@@ -45,26 +45,26 @@ mkTTName fc n =

45 otherwise -> PRef fc $ reflm "NErased"

47expandSugar :: DSL -> PTerm -> PTerm

48−expandSugar dsl (PLam fc n ty tm)

48+expandSugar dsl (PLam fc n nfc ty tm)

49 | Just lam <- dsl_lambda dsl

50 = let sc = PApp fc lam [ pexp (mkTTName fc n)

51 , pexp (var dsl n tm 0)]

52 in expandSugar dsl sc

53−expandSugar dsl (PLam fc n ty tm) = PLam fc n (expandSugar dsl ty) (expandSugar dsl tm)

53+expandSugar dsl (PLam fc n nfc ty tm) = PLam fc n nfc (expandSugar dsl ty) (expandSugar dsl tm)

54−expandSugar dsl (PLet fc n ty v tm)

54+expandSugar dsl (PLet fc n nfc ty v tm)

55 | Just letb <- dsl_let dsl

56 = let sc = PApp (fileFC "(dsl)") letb [ pexp (mkTTName fc n)

57 , pexp v

58 , pexp (var dsl n tm 0)]

59 in expandSugar dsl sc

60−expandSugar dsl (PLet fc n ty v tm) = PLet fc n (expandSugar dsl ty) (expandSugar dsl v) (expandSugar dsl tm)

60+expandSugar dsl (PLet fc n nfc ty v tm) = PLet fc n nfc (expandSugar dsl ty) (expandSugar dsl v) (expandSugar dsl tm)

61−expandSugar dsl (PPi p n ty tm)

61+expandSugar dsl (PPi p n fc ty tm)

62 | Just pi <- dsl_pi dsl

63 = let sc = PApp (fileFC "(dsl)") pi [ pexp (mkTTName (fileFC "(dsl)") n)

64 , pexp ty

65 , pexp (var dsl n tm 0)]

66 in expandSugar dsl sc

67−expandSugar dsl (PPi p n ty tm) = PPi p n (expandSugar dsl ty) (expandSugar dsl tm)

67+expandSugar dsl (PPi p n fc ty tm) = PPi p n fc (expandSugar dsl ty) (expandSugar dsl tm)

68expandSugar dsl (PApp fc t args) = PApp fc (expandSugar dsl t)

69 (map (fmap (expandSugar dsl)) args)

70expandSugar dsl (PAppBind fc t args) = PAppBind fc (expandSugar dsl t)

@@ -72,7 +72,7 @@ expandSugar dsl (PAppBind fc t args) = PAppBind fc (expandSugar dsl t)

72expandSugar dsl (PCase fc s opts) = PCase fc (expandSugar dsl s)

73 (map (pmap (expandSugar dsl)) opts)

74expandSugar dsl (PIfThenElse fc c t f) =

75− PApp fc (PRef (FC (fc_fname fc) (fc_start fc) (fc_start fc)) (sUN "ifThenElse"))

75+ PApp fc (PRef NoFC (sUN "ifThenElse"))

76 [ PExp 0 [] (sMN 0 "condition") $ expandSugar dsl c

77 , PExp 0 [] (sMN 0 "whenTrue") $ expandSugar dsl t

78 , PExp 0 [] (sMN 0 "whenFalse") $ expandSugar dsl f

@@ -95,20 +95,20 @@ expandSugar dsl (PDoBlock ds)

95 where

96 block b [DoExp fc tm] = tm

97 block b [a] = PElabError (Msg "Last statement in do block must be an expression")

98− block b (DoBind fc n tm : rest)

98+ block b (DoBind fc n nfc tm : rest)

99− = PApp fc b [pexp tm, pexp (PLam fc n Placeholder (block b rest))]

99+ = PApp fc b [pexp tm, pexp (PLam fc n nfc Placeholder (block b rest))]

100 block b (DoBindP fc p tm alts : rest)

101− = PApp fc b [pexp tm, pexp (PLam fc (sMN 0 "bpat") Placeholder

101+ = PApp fc b [pexp tm, pexp (PLam fc (sMN 0 "bpat") NoFC Placeholder

102 (PCase fc (PRef fc (sMN 0 "bpat"))

103 ((p, block b rest) : alts)))]

104− block b (DoLet fc n ty tm : rest)

104+ block b (DoLet fc n nfc ty tm : rest)

105− = PLet fc n ty tm (block b rest)

105+ = PLet fc n nfc ty tm (block b rest)

106 block b (DoLetP fc p tm : rest)

107 = PCase fc tm [(p, block b rest)]

108 block b (DoExp fc tm : rest)

109 = PApp fc b

110 [pexp tm,

111− pexp (PLam fc (sMN 0 "bindx") Placeholder (block b rest))]

111+ pexp (PLam fc (sMN 0 "bindx") NoFC Placeholder (block b rest))]

112 block b _ = PElabError (Msg "Invalid statement in do block")

113

114expandSugar dsl (PIdiom fc e) = expandSugar dsl $ unIdiom (dsl_apply dsl) (dsl_pure dsl) fc e

@@ -122,18 +122,18 @@ var dsl n t i = v' i t where

122 case dsl_var dsl of

123 Nothing -> PElabError (Msg "No 'variable' defined in dsl")

124 Just v -> PApp fc v [pexp (mkVar fc i)]

125− v' i (PLam fc n ty sc)

125+ v' i (PLam fc n nfc ty sc)

126 | Nothing <- dsl_lambda dsl

127− = PLam fc n ty (v' i sc)

127+ = PLam fc n nfc ty (v' i sc)

128− | otherwise = PLam fc n (v' i ty) (v' (i + 1) sc)

128+ | otherwise = PLam fc n nfc (v' i ty) (v' (i + 1) sc)

129− v' i (PLet fc n ty val sc)

129+ v' i (PLet fc n nfc ty val sc)

130 | Nothing <- dsl_let dsl

131− = PLet fc n (v' i ty) (v' i val) (v' i sc)

131+ = PLet fc n nfc (v' i ty) (v' i val) (v' i sc)

132− | otherwise = PLet fc n (v' i ty) (v' i val) (v' (i + 1) sc)

132+ | otherwise = PLet fc n nfc (v' i ty) (v' i val) (v' (i + 1) sc)

133− v' i (PPi p n ty sc)

133+ v' i (PPi p n fc ty sc)

134 | Nothing <- dsl_pi dsl

135− = PPi p n (v' i ty) (v' i sc)

135+ = PPi p n fc (v' i ty) (v' i sc)

136− | otherwise = PPi p n (v' i ty) (v' (i+1) sc)

136+ | otherwise = PPi p n fc (v' i ty) (v' (i+1) sc)

137 v' i (PTyped l r) = PTyped (v' i l) (v' i r)

138 v' i (PApp f x as) = PApp f (v' i x) (fmap (fmap (v' i)) as)

139 v' i (PCase f t as) = PCase f (v' i t) (fmap (pmap (v' i)) as)

@@ -187,9 +187,9 @@ debind b tm = let (tm', (bs, _)) = runState (db' tm) ([], 0) in

187 = do t' <- db' t

188 args' <- mapM dbArg args

189 return (PApp fc t' args')

190− db' (PLam fc n ty sc) = return (PLam fc n ty (debind b sc))

190+ db' (PLam fc n nfc ty sc) = return (PLam fc n nfc ty (debind b sc))

191− db' (PLet fc n ty v sc) = do v' <- db' v

191+ db' (PLet fc n nfc ty v sc) = do v' <- db' v

192− return (PLet fc n ty v' (debind b sc))

192+ return (PLet fc n nfc ty v' (debind b sc))

193 db' (PCase fc s opts) = do s' <- db' s

194 return (PCase fc s' (map (pmap (debind b)) opts))

195 db' (PPair fc p l r) = do l' <- db' l

@@ -212,6 +212,6 @@ debind b tm = let (tm', (bs, _)) = runState (db' tm) ([], 0) in

212

213 bindAll [] tm = tm

214 bindAll ((n, fc, t) : bs) tm

215− = PApp fc b [pexp t, pexp (PLam fc n Placeholder (bindAll bs tm))]

215+ = PApp fc b [pexp t, pexp (PLam fc n NoFC Placeholder (bindAll bs tm))]

216

217

src/Idris/DeepSeq.hs+33−21

@@ -129,10 +129,12 @@ instance NFData DataOpt where

129

130instance (NFData t) => NFData (PDecl' t) where

131 rnf (PFix x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

132− rnf (PTy x1 x2 x3 x4 x5 x6 x7)

132+ rnf (PTy x1 x2 x3 x4 x5 x6 x7 x8)

133 = rnf x1 `seq`

134 rnf x2 `seq`

135+ rnf x3 `seq`

136+ rnf x4 `seq`

135− rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` rnf x7 `seq` ()

137+ rnf x5 `seq` rnf x6 `seq` rnf x7 `seq` rnf x8 `seq` ()

136 rnf (PPostulate x1 x2 x3 x4 x5 x6 x7)

138 rnf (PPostulate x1 x2 x3 x4 x5 x6 x7)

137 = rnf x1 `seq`

139 = rnf x1 `seq`

138 rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` rnf x7 `seq` ()

140 rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` rnf x7 `seq` ()

@@ -145,12 +147,18 @@ instance (NFData t) => NFData (PDecl' t) where

145 rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` ()

147 rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` ()

146 rnf (PParams x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

148 rnf (PParams x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

147 rnf (PNamespace x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

149 rnf (PNamespace x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

148− rnf (PRecord x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11)

150+ rnf (PRecord x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12)

149 = rnf x1 `seq`

151 = rnf x1 `seq`

150 rnf x2 `seq`

152 rnf x2 `seq`

151 rnf x3 `seq`

153 rnf x3 `seq`

152− rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` rnf x7 `seq` rnf x8 `seq` rnf x9 `seq` rnf x10 `seq` rnf x11 `seq` ()

154+ rnf x4 `seq`

155+ rnf x5 `seq`

156+ rnf x6 `seq`

157+ rnf x7 `seq`

158+ rnf x8 `seq`

159+ rnf x9 `seq`

160+ rnf x10 `seq` rnf x11 `seq` rnf x12 `seq` ()

153− rnf (PClass x1 x2 x3 x4 x5 x6 x8 x7 x9 x10 x11)

161+ rnf (PClass x1 x2 x3 x4 x5 x6 x8 x7 x9 x10 x11 x12)

154 = rnf x1 `seq`

162 = rnf x1 `seq`

155 rnf x2 `seq`

163 rnf x2 `seq`

156 rnf x3 `seq`

164 rnf x3 `seq`

@@ -159,15 +167,19 @@ instance (NFData t) => NFData (PDecl' t) where

159 rnf x6 `seq`

167 rnf x6 `seq`

160 rnf x7 `seq`

168 rnf x7 `seq`

161 rnf x8 `seq`

169 rnf x8 `seq`

170+ rnf x9 `seq`

171+ rnf x10 `seq`

162− rnf x9 `seq` rnf x10 `seq` rnf x11 `seq` ()

172+ rnf x11 `seq` rnf x12 `seq` ()

163− rnf (PInstance x1 x2 x3 x4 x5 x6 x7 x8 x9 x10)

173+ rnf (PInstance x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11)

164 = rnf x1 `seq`

174 = rnf x1 `seq`

165 rnf x2 `seq`

175 rnf x2 `seq`

166 rnf x3 `seq`

176 rnf x3 `seq`

167 rnf x4 `seq`

177 rnf x4 `seq`

168 rnf x5 `seq`

178 rnf x5 `seq`

169 rnf x6 `seq`

179 rnf x6 `seq`

180+ rnf x7 `seq`

181+ rnf x8 `seq`

170− rnf x7 `seq` rnf x8 `seq` rnf x9 `seq` rnf x10 `seq` ()

182+ rnf x9 `seq` rnf x10 `seq` rnf x11 `seq` ()

171 rnf (PDSL x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

183 rnf (PDSL x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

172 rnf (PSyntax x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

184 rnf (PSyntax x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

173 rnf (PMutual x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

185 rnf (PMutual x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

@@ -197,20 +209,20 @@ instance (NFData t) => NFData (PClause' t) where

197 = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` ()

209 = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` ()

198

210

199instance (NFData t) => NFData (PData' t) where

211instance (NFData t) => NFData (PData' t) where

200− rnf (PDatadecl x1 x2 x3)

212+ rnf (PDatadecl x1 x2 x3 x4)

201− = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

213+ = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()

202− rnf (PLaterdecl x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

214+ rnf (PLaterdecl x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

203

215

204instance NFData PTerm where

216instance NFData PTerm where

205 rnf (PQuote x1) = rnf x1 `seq` ()

217 rnf (PQuote x1) = rnf x1 `seq` ()

206 rnf (PRef x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

218 rnf (PRef x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

207 rnf (PInferRef x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

219 rnf (PInferRef x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

208 rnf (PPatvar x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

220 rnf (PPatvar x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

209− rnf (PLam _ x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

221+ rnf (PLam _ x1 x2 x3 x4) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()

210− rnf (PPi x1 x2 x3 x4)

222+ rnf (PPi x1 x2 x3 x4 x5)

211− = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()

223+ = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` ()

212− rnf (PLet _ x1 x2 x3 x4)

224+ rnf (PLet _ x1 x2 x3 x4 x5)

213− = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()

225+ = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` ()

214 rnf (PTyped x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

226 rnf (PTyped x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

215 rnf (PAppImpl x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

227 rnf (PAppImpl x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

216 rnf (PApp x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

228 rnf (PApp x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

@@ -228,11 +240,11 @@ instance NFData PTerm where

228 rnf (PAs x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

240 rnf (PAs x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

229 rnf (PAlternative x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

241 rnf (PAlternative x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

230 rnf (PHidden x1) = rnf x1 `seq` ()

242 rnf (PHidden x1) = rnf x1 `seq` ()

231− rnf PType = ()

243+ rnf (PType fc) = rnf fc `seq` ()

232 rnf (PUniverse _) = ()

244 rnf (PUniverse _) = ()

233 rnf (PGoal x1 x2 x3 x4)

245 rnf (PGoal x1 x2 x3 x4)

234 = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()

246 = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()

235− rnf (PConstant x1) = x1 `seq` ()

247+ rnf (PConstant x1 x2) = x1 `seq` x2 `seq` ()

236 rnf Placeholder = ()

248 rnf Placeholder = ()

237 rnf (PDoBlock x1) = rnf x1 `seq` ()

249 rnf (PDoBlock x1) = rnf x1 `seq` ()

238 rnf (PIdiom x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

250 rnf (PIdiom x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

@@ -302,10 +314,10 @@ instance NFData ErrorReportPart where

302

314

303instance (NFData t) => NFData (PDo' t) where

315instance (NFData t) => NFData (PDo' t) where

304 rnf (DoExp x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

316 rnf (DoExp x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

305− rnf (DoBind x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

317+ rnf (DoBind x1 x2 x3 x4) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()

306 rnf (DoBindP x1 x2 x3 x4) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()

318 rnf (DoBindP x1 x2 x3 x4) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()

307− rnf (DoLet x1 x2 x3 x4)

319+ rnf (DoLet x1 x2 x3 x4 x5)

308− = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()

320+ = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` ()

309 rnf (DoLetP x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

321 rnf (DoLetP x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

310

322

311instance (NFData t) => NFData (PArg' t) where

323instance (NFData t) => NFData (PArg' t) where

src/Idris/Delaborate.hs+25−22

@@ -61,40 +61,40 @@ delabTy' ist imps tm fullname mvs = de [] imps tm

61 Just (Just _, mi, _) -> mkMVApp n []

62 _ -> PRef un n

63 de env _ (Bind n (Lam ty) sc)

64− = PLam un n (de env [] ty) (de ((n,n):env) [] sc)

64+ = PLam un n NoFC (de env [] ty) (de ((n,n):env) [] sc)

65 de env is (Bind n (Pi (Just impl) ty _) sc)

66 | tcinstance impl

67− = PPi constraint n (de env [] ty) (de ((n,n):env) is sc)

67+ = PPi constraint n NoFC (de env [] ty) (de ((n,n):env) is sc)

68 | otherwise

69− = PPi (Imp [] Dynamic False (Just impl)) n (de env [] ty) (de ((n,n):env) is sc)

69+ = PPi (Imp [] Dynamic False (Just impl)) n NoFC (de env [] ty) (de ((n,n):env) is sc)

70 de env ((PImp { argopts = opts }):is) (Bind n (Pi _ ty _) sc)

71− = PPi (Imp opts Dynamic False Nothing) n (de env [] ty) (de ((n,n):env) is sc)

71+ = PPi (Imp opts Dynamic False Nothing) n NoFC (de env [] ty) (de ((n,n):env) is sc)

72 de env (PConstraint _ _ _ _:is) (Bind n (Pi _ ty _) sc)

73− = PPi constraint n (de env [] ty) (de ((n,n):env) is sc)

73+ = PPi constraint n NoFC (de env [] ty) (de ((n,n):env) is sc)

74 de env (PTacImplicit _ _ _ tac _:is) (Bind n (Pi _ ty _) sc)

75− = PPi (tacimpl tac) n (de env [] ty) (de ((n,n):env) is sc)

75+ = PPi (tacimpl tac) n NoFC (de env [] ty) (de ((n,n):env) is sc)

76 de env (plic:is) (Bind n (Pi _ ty _) sc)

77 = PPi (Exp (argopts plic) Dynamic False)

78− n

78+ n NoFC

79 (de env [] ty)

80 (de ((n,n):env) is sc)

81 de env [] (Bind n (Pi _ ty _) sc)

82− = PPi expl n (de env [] ty) (de ((n,n):env) [] sc)

82+ = PPi expl n NoFC (de env [] ty) (de ((n,n):env) [] sc)

84 de env imps (Bind n (Let ty val) sc)

85 | isCaseApp sc

86 , (P _ cOp _, args) <- unApply sc

87 , Just caseblock <- delabCase env imps n val cOp args = caseblock

88 | otherwise =

89− PLet un n (de env [] ty) (de env [] val) (de ((n,n):env) [] sc)

89+ PLet un n NoFC (de env [] ty) (de env [] val) (de ((n,n):env) [] sc)

90 de env _ (Bind n (Hole ty) sc) = de ((n, sUN "[__]"):env) [] sc

91 de env _ (Bind n (Guess ty val) sc) = de ((n, sUN "[__]"):env) [] sc

92 de env plic (Bind n bb sc) = de ((n,n):env) [] sc

93− de env _ (Constant i) = PConstant i

93+ de env _ (Constant i) = PConstant NoFC i

94 de env _ (Proj _ _) = error "Delaboration got run-time-only Proj!"

95 de env _ Erased = Placeholder

96 de env _ Impossible = Placeholder

97− de env _ (TType i) = PType

97+ de env _ (TType i) = PType un

98 de env _ (UType u) = PUniverse u

100 dens x | fullname = x

@@ -306,7 +306,7 @@ pprintErr' i (InvalidTCArg n t)

306 <> annName n <$>

307 text "(Type class arguments must be injective)"

308pprintErr' i (CantResolveAlts as) = text "Can't disambiguate name:" <+>

309− align (cat (punctuate (comma <> space) (map (fmap (fancifyAnnots i) . annName) as)))

309+ align (cat (punctuate (comma <> space) (map (fmap (fancifyAnnots i True) . annName) as)))

310pprintErr' i (NoTypeDecl n) = text "No type declaration for" <+> annName n

311pprintErr' i (NoSuchVariable n) = text "No such variable" <+> annName n

312pprintErr' i (WithFnType ty) =

@@ -474,14 +474,14 @@ addImplicitDiffs x y

474 else (a { getTm = a' } : as',

475 b { getTm = b' } : bs')

476 addShows xs ys = (xs, ys)

477− addI (PLam fc n a b) (PLam fc' n' c d)

477+ addI (PLam fc n nfc a b) (PLam fc' n' nfc' c d)

478 = let (a', c') = addI a c

479 (b', d') = addI b d in

480− (PLam fc n a' b', PLam fc' n' c' d')

480+ (PLam fc n nfc a' b', PLam fc' n' nfc' c' d')

481− addI (PPi p n a b) (PPi p' n' c d)

481+ addI (PPi p n fc a b) (PPi p' n' fc' c d)

482 = let (a', c') = addI a c

483 (b', d') = addI b d in

484− (PPi p n a' b', PPi p' n' c' d')

484+ (PPi p n fc a' b', PPi p' n' fc' c' d')

485 addI (PPair fc pi a b) (PPair fc' pi' c d)

486 = let (a', c') = addI a c

487 (b', d') = addI b d in

@@ -498,9 +498,9 @@ addImplicitDiffs x y

498 expLike (PApp _ f as) (PApp _ f' as')

499 = expLike f f' && length as == length as' &&

500 and (zipWith expLike (getExps as) (getExps as'))

501− expLike (PPi _ n s t) (PPi _ n' s' t')

501+ expLike (PPi _ n fc s t) (PPi _ n' fc' s' t')

502 = n == n' && expLike s s' && expLike t t'

503− expLike (PLam _ n s t) (PLam _ n' s' t')

503+ expLike (PLam _ n _ s t) (PLam _ n' _ s' t')

504 = n == n' && expLike s s' && expLike t t'

505 expLike (PPair _ _ x y) (PPair _ _ x' y') = expLike x x' && expLike y y'

506 expLike (PDPair _ _ x _ y) (PDPair _ _ x' _ y') = expLike x x' && expLike y y'

@@ -525,8 +525,9 @@ annName' n str = annotate (AnnName n Nothing Nothing Nothing) (text str)

525annTm :: Term -> Doc OutputAnnotation -> Doc OutputAnnotation

526annTm tm = annotate (AnnTerm [] tm)

527

528+-- | Add extra metadata to an output annotation, optionally marking metavariables.

528−fancifyAnnots :: IState -> OutputAnnotation -> OutputAnnotation

529+fancifyAnnots :: IState -> Bool -> OutputAnnotation -> OutputAnnotation

529−fancifyAnnots ist annot@(AnnName n _ _ _) =

530+fancifyAnnots ist meta annot@(AnnName n _ _ _) =

530 do let ctxt = tt_ctxt ist

531 do let ctxt = tt_ctxt ist

531 docs = docOverview ist n

532 docs = docOverview ist n

532 ty = Just (getTy ist n)

533 ty = Just (getTy ist n)

@@ -534,7 +535,9 @@ fancifyAnnots ist annot@(AnnName n _ _ _) =

534 _ | isDConName n ctxt -> AnnName n (Just DataOutput) docs ty

535 _ | isDConName n ctxt -> AnnName n (Just DataOutput) docs ty

535 _ | isFnName n ctxt -> AnnName n (Just FunOutput) docs ty

536 _ | isFnName n ctxt -> AnnName n (Just FunOutput) docs ty

536 _ | isTConName n ctxt -> AnnName n (Just TypeOutput) docs ty

537 _ | isTConName n ctxt -> AnnName n (Just TypeOutput) docs ty

538+ _ | isMetavarName n ist -> if meta

537− _ | isMetavarName n ist -> AnnName n (Just MetavarOutput) docs ty

539+ then AnnName n (Just MetavarOutput) docs ty

540+ else AnnName n (Just FunOutput) docs ty

538 _ | isPostulateName n ist -> AnnName n (Just PostulateOutput) docs ty

541 _ | isPostulateName n ist -> AnnName n (Just PostulateOutput) docs ty

539 _ | otherwise -> annot

542 _ | otherwise -> annot

540 where docOverview :: IState -> Name -> Maybe String -- pretty-print first paragraph of docs

543 where docOverview :: IState -> Name -> Maybe String -- pretty-print first paragraph of docs

@@ -552,7 +555,7 @@ fancifyAnnots ist annot@(AnnName n _ _ _) =

552 getTy ist n = let theTy = pprintPTerm (ppOptionIst ist) [] [] (idris_infixes ist) $

555 getTy ist n = let theTy = pprintPTerm (ppOptionIst ist) [] [] (idris_infixes ist) $

553 delabTy ist n

556 delabTy ist n

554 in (displayS . renderPretty 1.0 50 $ theTy) ""

557 in (displayS . renderPretty 1.0 50 $ theTy) ""

555−fancifyAnnots _ annot = annot

558+fancifyAnnots _ _ annot = annot

556

559

557showSc :: IState -> [(Name, Term)] -> Doc OutputAnnotation

560showSc :: IState -> [(Name, Term)] -> Doc OutputAnnotation

558showSc i [] = empty

561showSc i [] = empty

src/Idris/Docs.hs+15−15

@@ -170,8 +170,8 @@ pprintDocs ist (ClassDoc n doc meths params instances subclasses superclasses ct

170 dumpInstance :: PTerm -> Doc OutputAnnotation

171 dumpInstance = pprintPTerm ppo params' [] infixes

172

173− prettifySubclasses (PPi (Constraint _ _) _ tm _) = prettifySubclasses tm

173+ prettifySubclasses (PPi (Constraint _ _) _ _ tm _) = prettifySubclasses tm

174− prettifySubclasses (PPi plcity nm t1 t2) = PPi plcity (safeHead nm pNames) (prettifySubclasses t1) (prettifySubclasses t2)

174+ prettifySubclasses (PPi plcity nm fc t1 t2) = PPi plcity (safeHead nm pNames) NoFC (prettifySubclasses t1) (prettifySubclasses t2)

175 prettifySubclasses (PApp fc ref args) = PApp fc ref $ updateArgs pNames args

176 prettifySubclasses tm = tm

177

@@ -185,8 +185,8 @@ pprintDocs ist (ClassDoc n doc meths params instances subclasses superclasses ct

185 updateRef nm (PRef fc _) = PRef fc nm

186 updateRef _ pt = pt

187

188− isSubclass (PPi (Constraint _ _) _ (PApp _ _ args) (PApp _ (PRef _ nm) args')) = nm == n && map getTm args == map getTm args'

188+ isSubclass (PPi (Constraint _ _) _ _ (PApp _ _ args) (PApp _ (PRef _ nm) args')) = nm == n && map getTm args == map getTm args'

189− isSubclass (PPi _ _ _ pt) = isSubclass pt

189+ isSubclass (PPi _ _ _ _ pt) = isSubclass pt

190 isSubclass _ = False

191

192 prettyParameters =

@@ -271,12 +271,12 @@ docClass n ci

271 namedInst n@(UN _) = Just n

272 namedInst _ = Nothing

273

274− getDInst (PInstance _ _ _ _ _ _ _ t _ _) = Just t

274+ getDInst (PInstance _ _ _ _ _ _ _ _ t _ _) = Just t

275− getDInst _ = Nothing

275+ getDInst _ = Nothing

276

277− isSubclass (PPi (Constraint _ _) _ (PApp _ _ args) (PApp _ (PRef _ nm) args'))

277+ isSubclass (PPi (Constraint _ _) _ _ (PApp _ _ args) (PApp _ (PRef _ nm) args'))

278 = nm == n && map getTm args == map getTm args'

279− isSubclass (PPi _ _ _ pt)

279+ isSubclass (PPi _ _ _ _ pt)

280 = isSubclass pt

281 isSubclass _

282 = False

@@ -302,18 +302,18 @@ docFun n

302 funName n = show n

303

304getPArgNames :: PTerm -> [(Name, Docstring DocTerm)] -> [(Name, PTerm, Plicity, Maybe (Docstring DocTerm))]

305−getPArgNames (PPi plicity name ty body) ds =

305+getPArgNames (PPi plicity name _ ty body) ds =

306 (name, ty, plicity, lookup name ds) : getPArgNames body ds

307getPArgNames _ _ = []

308

309pprintConstDocs :: IState -> Const -> String -> Doc OutputAnnotation

310pprintConstDocs ist c str = text "Primitive" <+> text (if constIsType c then "type" else "value") <+>

311− pprintPTerm (ppOptionIst ist) [] [] [] (PConstant c) <+> colon <+>

311+ pprintPTerm (ppOptionIst ist) [] [] [] (PConstant NoFC c) <+> colon <+>

312 pprintPTerm (ppOptionIst ist) [] [] [] (t c) <>

313 nest 4 (line <> text str)

314

315− where t (Fl _) = PConstant $ AType ATFloat

315+ where t (Fl _) = PConstant NoFC $ AType ATFloat

316− t (BI _) = PConstant $ AType (ATInt ITBig)

316+ t (BI _) = PConstant NoFC $ AType (ATInt ITBig)

317− t (Str _) = PConstant StrType

317+ t (Str _) = PConstant NoFC StrType

318− t (Ch c) = PConstant $ AType (ATInt ITChar)

318+ t (Ch c) = PConstant NoFC $ AType (ATInt ITChar)

319− t _ = PType

319+ t _ = PType NoFC

src/Idris/Elab/AsPat.hs+1−1

@@ -17,7 +17,7 @@ desugarAs lhs rhs

17 bindPats :: [(Name, FC, PTerm)] -> PTerm -> PTerm

18 bindPats [] rhs = rhs

19 bindPats ((n, fc, tm) : ps) rhs

20− = PLet fc n Placeholder tm (bindPats ps rhs)

20+ = PLet fc n NoFC Placeholder tm (bindPats ps rhs)

22collectAs :: PTerm -> State [(Name, FC, PTerm)] PTerm

23collectAs (PAs fc n tm) = do tm' <- collectAs tm

src/Idris/Elab/Class.hs+68−53

@@ -15,7 +15,7 @@ import Idris.Primitives

15import Idris.Inliner

16import Idris.PartialEval

17import Idris.DeepSeq

18−import Idris.Output (iputStrLn, pshow, iWarn)

18+import Idris.Output (iputStrLn, pshow, iWarn, sendHighlighting)

19import IRTS.Lang

21import Idris.Elab.Type

@@ -54,18 +54,22 @@ data MArgTy = IA Name | EA Name | CA deriving Show

55elabClass :: ElabInfo -> SyntaxInfo -> Docstring (Either Err PTerm) ->

56 FC -> [(Name, PTerm)] ->

57− Name -> [(Name, PTerm)] -> [(Name, Docstring (Either Err PTerm))] ->

57+ Name -> FC -> [(Name, FC, PTerm)] -> [(Name, Docstring (Either Err PTerm))] ->

58+ [(Name, FC)] {- ^ determining params -} ->

58− [Name] -> [PDecl] ->

59+ [PDecl] {- ^ class body -} ->

59− Maybe Name {- ^ instance ctor name -} ->

60+ Maybe (Name, FC) {- ^ instance ctor name and location -} ->

60 Docstring (Either Err PTerm) {- ^ instance ctor docs -} ->

61 Docstring (Either Err PTerm) {- ^ instance ctor docs -} ->

61 Idris ()

62 Idris ()

62−elabClass info syn_in doc fc constraints tn ps pDocs fds ds mcn cd

63+elabClass info syn_in doc fc constraints tn tnfc ps pDocs fds ds mcn cd

63− = do let cn = fromMaybe (SN (InstanceCtorN tn)) mcn

64+ = do let cn = fromMaybe (SN (InstanceCtorN tn)) (fst <$> mcn)

64− let tty = pibind ps PType

65+ let tty = pibind (map (\(n, _, ty) -> (n, ty)) ps) (PType fc)

65 let constraint = PApp fc (PRef fc tn)

66 let constraint = PApp fc (PRef fc tn)

66− (map (pexp . PRef fc) (map fst ps))

67+ (map (pexp . PRef fc) (map (\(n, _, _) -> n) ps))

69+ let syn =

68− let syn = syn_in { using = addToUsing (using syn_in) ps }

70+ syn_in { using = addToUsing (using syn_in)

71+ [(pn, pt) | (pn, _, pt) <- ps]

72+ }

70 -- build data declaration

74 -- build data declaration

71 let mdecls = filter tydecl ds -- method declarations

75 let mdecls = filter tydecl ds -- method declarations

@@ -77,20 +81,22 @@ elabClass info syn_in doc fc constraints tn ps pDocs fds ds mcn cd

77 defs <- mapM (defdecl (map (\ (x,y,z) -> z) ims) constraint)

81 defs <- mapM (defdecl (map (\ (x,y,z) -> z) ims) constraint)

78 (filter clause ds)

82 (filter clause ds)

79 let (methods, imethods)

83 let (methods, imethods)

80− = unzip (map (\ ( x,y,z) -> (x, y)) ims)

84+ = unzip (map (\ (x, y, z) -> (x, y)) ims)

81 let defaults = map (\ (x, (y, z)) -> (x,y)) defs

85 let defaults = map (\ (x, (y, z)) -> (x,y)) defs

82 -- build instance constructor type

86 -- build instance constructor type

83− let cty = impbind ps $ conbind constraints

87+ let cty = impbind [(pn, pt) | (pn, _, pt) <- ps] $ conbind constraints

84 $ pibind (map (\ (n, ty) -> (nsroot n, ty)) methods)

88 $ pibind (map (\ (n, ty) -> (nsroot n, ty)) methods)

85 constraint

89 constraint

90+

86− let cons = [(cd, pDocs ++ mapMaybe memberDocs ds, cn, cty, fc, [])]

91+ let cons = [(cd, pDocs ++ mapMaybe memberDocs ds, cn, NoFC, cty, fc, [])]

87− let ddecl = PDatadecl tn tty cons

92+ let ddecl = PDatadecl tn NoFC tty cons

93+

88 logLvl 5 $ "Class data " ++ show (showDImp verbosePPOption ddecl)

94 logLvl 5 $ "Class data " ++ show (showDImp verbosePPOption ddecl)

89 -- Elaborate the data declaration

95 -- Elaborate the data declaration

90 elabData info (syn { no_imp = no_imp syn ++ mnames,

96 elabData info (syn { no_imp = no_imp syn ++ mnames,

91 imp_methods = mnames }) doc pDocs fc [] ddecl

97 imp_methods = mnames }) doc pDocs fc [] ddecl

92− dets <- findDets cn fds

98+ dets <- findDets cn (map fst fds)

93− addClass tn (CI cn (map nodoc imethods) defaults idecls (map fst ps) [] dets)

99+ addClass tn (CI cn (map nodoc imethods) defaults idecls (map (\(n, _, _) -> n) ps) [] dets)

100

95 -- for each constraint, build a top level function to chase it

101 -- for each constraint, build a top level function to chase it

96 cfns <- mapM (cfun cn constraint syn (map fst imethods)) constraints

102 cfns <- mapM (cfun cn constraint syn (map fst imethods)) constraints

@@ -106,16 +112,24 @@ elabClass info syn_in doc fc constraints tn ps pDocs fds ds mcn cd

106 -- add the default definitions

112 -- add the default definitions

107 mapM_ (rec_elabDecl info EAll info) (concat (map (snd.snd) defs))

113 mapM_ (rec_elabDecl info EAll info) (concat (map (snd.snd) defs))

108 addIBC (IBCClass tn)

114 addIBC (IBCClass tn)

115+

116+ sendHighlighting $

117+ [(tnfc, AnnName tn Nothing Nothing Nothing)] ++

118+ [(pnfc, AnnBoundName pn False) | (pn, pnfc, _) <- ps] ++

119+ [(fdfc, AnnBoundName fc False) | (fc, fdfc) <- fds] ++

120+ maybe [] (\(conN, conNFC) -> [(conNFC, AnnName conN Nothing Nothing Nothing)]) mcn

121+

109 where

122 where

110− nodoc (n, (_, o, t)) = (n, (o, t))

123+ nodoc (n, (_, _, o, t)) = (n, (o, t))

124+

111 pibind [] x = x

125 pibind [] x = x

112− pibind ((n, ty): ns) x = PPi expl n ty (pibind ns (chkUniq ty x))

126+ pibind ((n, ty): ns) x = PPi expl n NoFC ty (pibind ns (chkUniq ty x))

113

127

114 -- To make sure the type constructor of the class is in the appropriate

128 -- To make sure the type constructor of the class is in the appropriate

115 -- uniqueness hierarchy

129 -- uniqueness hierarchy

116− chkUniq u@(PUniverse _) PType = u

130+ chkUniq u@(PUniverse _) (PType _) = u

117 chkUniq (PUniverse l) (PUniverse r) = PUniverse (min l r)

131 chkUniq (PUniverse l) (PUniverse r) = PUniverse (min l r)

118− chkUniq (PPi _ _ _ sc) t = chkUniq sc t

132+ chkUniq (PPi _ _ _ _ sc) t = chkUniq sc t

119 chkUniq _ t = t

133 chkUniq _ t = t

120

134

121 mdec :: Name -> Name

135 mdec :: Name -> Name

@@ -125,7 +139,7 @@ elabClass info syn_in doc fc constraints tn ps pDocs fds ds mcn cd

125

139

126 -- TODO: probably should normalise

140 -- TODO: probably should normalise

127 checkDefaultSuperclassInstance :: PDecl -> Idris ()

141 checkDefaultSuperclassInstance :: PDecl -> Idris ()

128− checkDefaultSuperclassInstance (PInstance _ _ _ fc cs n ps _ _ _)

142+ checkDefaultSuperclassInstance (PInstance _ _ _ fc cs n _ ps _ _ _)

129 = do when (not $ null cs) . tclift

143 = do when (not $ null cs) . tclift

130 $ tfail (At fc (Msg $ "Default superclass instances can't have constraints."))

144 $ tfail (At fc (Msg $ "Default superclass instances can't have constraints."))

131 i <- getIState

145 i <- getIState

@@ -137,40 +151,41 @@ elabClass info syn_in doc fc constraints tn ps pDocs fds ds mcn cd

137

151

138 impbind :: [(Name, PTerm)] -> PTerm -> PTerm

152 impbind :: [(Name, PTerm)] -> PTerm -> PTerm

139 impbind [] x = x

153 impbind [] x = x

140− impbind ((n, ty): ns) x = PPi impl n ty (impbind ns x)

154+ impbind ((n, ty): ns) x = PPi impl n NoFC ty (impbind ns x)

141

155

142 conbind :: [(Name, PTerm)] -> PTerm -> PTerm

156 conbind :: [(Name, PTerm)] -> PTerm -> PTerm

143− conbind ((c, ty) : ns) x = PPi constraint c ty (conbind ns x)

157+ conbind ((c, ty) : ns) x = PPi constraint c NoFC ty (conbind ns x)

144 conbind [] x = x

158 conbind [] x = x

145

159

146− getMName (PTy _ _ _ _ _ n _) = nsroot n

160+ getMName (PTy _ _ _ _ _ n nfc _) = nsroot n

147− tdecl allmeths (PTy doc _ syn _ o n t)

161+ tdecl allmeths (PTy doc _ syn _ o n nfc t)

148− = do t' <- implicit' info syn (map fst ps ++ allmeths) n t

162+ = do t' <- implicit' info syn (map (\(n, _, _) -> n) ps ++ allmeths) n t

149 logLvl 2 $ "Method " ++ show n ++ " : " ++ showTmImpls t'

163 logLvl 2 $ "Method " ++ show n ++ " : " ++ showTmImpls t'

150− return ( (n, (toExp (map fst ps) Exp t')),

164+ return ( (n, (toExp (map (\(pn, _, _) -> pn) ps) Exp t')),

151− (n, (doc, o, (toExp (map fst ps)

165+ (n, (nfc, doc, o, (toExp (map (\(pn, _, _) -> pn) ps)

152− (\ l s p -> Imp l s p Nothing) t'))),

166+ (\ l s p -> Imp l s p Nothing) t'))),

153− (n, (syn, o, t) ) )

167+ (n, (nfc, syn, o, t) ) )

154 tdecl _ _ = ifail "Not allowed in a class declaration"

168 tdecl _ _ = ifail "Not allowed in a class declaration"

155

169

156 -- Create default definitions

170 -- Create default definitions

157 defdecl mtys c d@(PClauses fc opts n cs) =

171 defdecl mtys c d@(PClauses fc opts n cs) =

158 case lookup n mtys of

172 case lookup n mtys of

173+ Just (nfc, syn, o, ty) ->

159− Just (syn, o, ty) -> do let ty' = insertConstraint c ty

174+ do let ty' = insertConstraint c ty

160− let ds = map (decorateid defaultdec)

175+ let ds = map (decorateid defaultdec)

161− [PTy emptyDocstring [] syn fc [] n ty',

176+ [PTy emptyDocstring [] syn fc [] n nfc ty',

162− PClauses fc (o ++ opts) n cs]

177+ PClauses fc (o ++ opts) n cs]

163− iLOG (show ds)

178+ iLOG (show ds)

164− return (n, ((defaultdec n, ds!!1), ds))

179+ return (n, ((defaultdec n, ds!!1), ds))

165 _ -> ifail $ show n ++ " is not a method"

180 _ -> ifail $ show n ++ " is not a method"

166 defdecl _ _ _ = ifail "Can't happen (defdecl)"

181 defdecl _ _ _ = ifail "Can't happen (defdecl)"

167

182

168 defaultdec (UN n) = sUN ("default#" ++ str n)

183 defaultdec (UN n) = sUN ("default#" ++ str n)

169 defaultdec (NS n ns) = NS (defaultdec n) ns

184 defaultdec (NS n ns) = NS (defaultdec n) ns

170

185

171− tydecl (PTy _ _ _ _ _ _ _) = True

186+ tydecl (PTy _ _ _ _ _ _ _ _) = True

172 tydecl _ = False

187 tydecl _ = False

173− instdecl (PInstance _ _ _ _ _ _ _ _ _ _) = True

188+ instdecl (PInstance _ _ _ _ _ _ _ _ _ _ _) = True

174 instdecl _ = False

189 instdecl _ = False

175 clause (PClauses _ _ _ _) = True

190 clause (PClauses _ _ _ _) = True

176 clause _ = False

191 clause _ = False

@@ -184,7 +199,7 @@ elabClass info syn_in doc fc constraints tn ps pDocs fds ds mcn cd

184 let capp = PApp fc (PRef fc cn) (map (pexp . PRef fc) mnames)

199 let capp = PApp fc (PRef fc cn) (map (pexp . PRef fc) mnames)

185 let lhs = PApp fc (PRef fc cfn) [pconst capp]

200 let lhs = PApp fc (PRef fc cfn) [pconst capp]

186 let rhs = PResolveTC (fileFC "HACK")

201 let rhs = PResolveTC (fileFC "HACK")

187− let ty = PPi constraint cnm c con

202+ let ty = PPi constraint cnm NoFC c con

188 logLvl 2 ("Dictionary constraint: " ++ showTmImpls ty)

203 logLvl 2 ("Dictionary constraint: " ++ showTmImpls ty)

189 logLvl 2 (showTmImpls lhs ++ " = " ++ showTmImpls rhs)

204 logLvl 2 (showTmImpls lhs ++ " = " ++ showTmImpls rhs)

190 i <- getIState

205 i <- getIState

@@ -197,12 +212,12 @@ elabClass info syn_in doc fc constraints tn ps pDocs fds ds mcn cd

197 addInstance False conn' cfn

212 addInstance False conn' cfn

198 addIBC (IBCInstance False conn' cfn)

213 addIBC (IBCInstance False conn' cfn)

199-- iputStrLn ("Added " ++ show (conn, cfn, ty))

214-- iputStrLn ("Added " ++ show (conn, cfn, ty))

200− return [PTy emptyDocstring [] syn fc [] cfn ty,

215+ return [PTy emptyDocstring [] syn fc [] cfn NoFC ty,

201 PClauses fc [Dictionary] cfn [PClause fc cfn lhs [] rhs []]]

216 PClauses fc [Dictionary] cfn [PClause fc cfn lhs [] rhs []]]

202

217

203 -- Generate a top level function which looks up a method in a given

218 -- Generate a top level function which looks up a method in a given

204 -- dictionary (this is inlinable, always)

219 -- dictionary (this is inlinable, always)

205− tfun cn c syn all (m, (doc, o, ty))

220+ tfun cn c syn all (m, (mfc, doc, o, ty))

206 = do let ty' = expandMethNS syn (insertConstraint c ty)

221 = do let ty' = expandMethNS syn (insertConstraint c ty)

207 let mnames = take (length all) $ map (\x -> sMN x "meth") [0..]

222 let mnames = take (length all) $ map (\x -> sMN x "meth") [0..]

208 let capp = PApp fc (PRef fc cn) (map (pexp . PRef fc) mnames)

223 let capp = PApp fc (PRef fc cn) (map (pexp . PRef fc) mnames)

@@ -213,12 +228,12 @@ elabClass info syn_in doc fc constraints tn ps pDocs fds ds mcn cd

213 logLvl 2 ("Top level type: " ++ showTmImpls ty')

228 logLvl 2 ("Top level type: " ++ showTmImpls ty')

214 iLOG (show (m, ty', capp, margs))

229 iLOG (show (m, ty', capp, margs))

215 logLvl 2 ("Definition: " ++ showTmImpls lhs ++ " = " ++ showTmImpls rhs)

230 logLvl 2 ("Definition: " ++ showTmImpls lhs ++ " = " ++ showTmImpls rhs)

216− return [PTy doc [] syn fc o m ty',

231+ return [PTy doc [] syn fc o m mfc ty',

217 PClauses fc [Inlinable] m [PClause fc m lhs [] rhs []]]

232 PClauses fc [Inlinable] m [PClause fc m lhs [] rhs []]]

218

233

219− getMArgs (PPi (Imp _ _ _ _) n ty sc) = IA n : getMArgs sc

234+ getMArgs (PPi (Imp _ _ _ _) n _ ty sc) = IA n : getMArgs sc

220− getMArgs (PPi (Exp _ _ _) n ty sc) = EA n : getMArgs sc

235+ getMArgs (PPi (Exp _ _ _) n _ ty sc) = EA n : getMArgs sc

221− getMArgs (PPi (Constraint _ _) n ty sc) = CA : getMArgs sc

236+ getMArgs (PPi (Constraint _ _) n _ ty sc) = CA : getMArgs sc

222 getMArgs _ = []

237 getMArgs _ = []

223

238

224 getMeth (m:ms) (a:as) x | x == a = PRef fc m

239 getMeth (m:ms) (a:as) x | x == a = PRef fc m

@@ -234,24 +249,24 @@ elabClass info syn_in doc fc constraints tn ps pDocs fds ds mcn cd

234 rhsArgs (CA : xs) ns = pconst (PResolveTC fc) : rhsArgs xs ns

249 rhsArgs (CA : xs) ns = pconst (PResolveTC fc) : rhsArgs xs ns

235 rhsArgs [] _ = []

250 rhsArgs [] _ = []

236

251

237− insertConstraint c (PPi p@(Imp _ _ _ _) n ty sc)

252+ insertConstraint c (PPi p@(Imp _ _ _ _) n fc ty sc)

238− = PPi p n ty (insertConstraint c sc)

253+ = PPi p n fc ty (insertConstraint c sc)

239 insertConstraint c sc = PPi (constraint { pstatic = Static })

254 insertConstraint c sc = PPi (constraint { pstatic = Static })

240− (sMN 0 "class") c sc

255+ (sMN 0 "class") NoFC c sc

241

256

242 -- make arguments explicit and don't bind class parameters

257 -- make arguments explicit and don't bind class parameters

243− toExp ns e (PPi (Imp l s p _) n ty sc)

258+ toExp ns e (PPi (Imp l s p _) n fc ty sc)

244 | n `elem` ns = toExp ns e sc

259 | n `elem` ns = toExp ns e sc

245− | otherwise = PPi (e l s p) n ty (toExp ns e sc)

260+ | otherwise = PPi (e l s p) n fc ty (toExp ns e sc)

246− toExp ns e (PPi p n ty sc) = PPi p n ty (toExp ns e sc)

261+ toExp ns e (PPi p n fc ty sc) = PPi p n fc ty (toExp ns e sc)

247 toExp ns e sc = sc

262 toExp ns e sc = sc

248

263

249memberDocs :: PDecl -> Maybe (Name, Docstring (Either Err PTerm))

264memberDocs :: PDecl -> Maybe (Name, Docstring (Either Err PTerm))

250−memberDocs (PTy d _ _ _ _ n _) = Just (basename n, d)

265+memberDocs (PTy d _ _ _ _ n _ _) = Just (basename n, d)

251memberDocs (PPostulate _ d _ _ _ n _) = Just (basename n, d)

266memberDocs (PPostulate _ d _ _ _ n _) = Just (basename n, d)

252memberDocs (PData d _ _ _ _ pdata) = Just (basename $ d_name pdata, d)

267memberDocs (PData d _ _ _ _ pdata) = Just (basename $ d_name pdata, d)

253−memberDocs (PRecord d _ _ _ n _ _ _ _ _ _ ) = Just (basename n, d)

268+memberDocs (PRecord d _ _ _ n _ _ _ _ _ _ _ ) = Just (basename n, d)

254−memberDocs (PClass d _ _ _ n _ _ _ _ _ _) = Just (basename n, d)

269+memberDocs (PClass d _ _ _ n _ _ _ _ _ _ _) = Just (basename n, d)

255memberDocs _ = Nothing

270memberDocs _ = Nothing

256

271

257

272

src/Idris/Elab/Clause.hs+30−16

@@ -16,7 +16,7 @@ import Idris.Inliner

16import Idris.PartialEval

17import Idris.Transforms

18import Idris.DeepSeq

19−import Idris.Output (iputStrLn, pshow, iWarn, iRenderResult)

19+import Idris.Output (iputStrLn, pshow, iWarn, iRenderResult, sendHighlighting)

20import IRTS.Lang

22import Idris.Elab.AsPat

@@ -374,7 +374,7 @@ elabPE info fc caller r =

374 logLvl 2 $ show n ++ " transformation rule: " ++

375 show rhs ++ " ==> " ++ show lhs

376

377− elabType info defaultSyntax emptyDocstring [] fc opts newnm specTy

377+ elabType info defaultSyntax emptyDocstring [] fc opts newnm NoFC specTy

378 let def = map (\(lhs, rhs) ->

379 PClause fc newnm lhs [] rhs [])

380 (pe_clauses specdecl)

@@ -453,9 +453,10 @@ checkPossible info fc tcgen fname lhs_in

453 -- if the LHS type checks, it is possible

454 case elaborate ctxt (idris_datatypes i) (sMN 0 "patLHS") infP initEState

455 (erun fc (buildTC i info ELHS [] fname (infTerm lhs))) of

456− OK (ElabResult lhs' _ _ ctxt' newDecls, _) ->

456+ OK (ElabResult lhs' _ _ ctxt' newDecls highlights, _) ->

457 do setContext ctxt'

458 processTacticDecls info newDecls

459+ sendHighlighting highlights

459 let lhs_tm = orderPats (getInferTerm lhs')

460 let lhs_tm = orderPats (getInferTerm lhs')

460 case recheck ctxt [] (forget lhs_tm) lhs_tm of

461 case recheck ctxt [] (forget lhs_tm) lhs_tm of

461 OK _ -> return True

462 OK _ -> return True

@@ -537,7 +538,7 @@ elabClause info opts (cnum, PClause fc fname lhs_in_as withs rhs_in_as wherebloc

537 logLvl 4 ("Fixed parameters: " ++ show params ++ " from " ++ show lhs_in ++

538 logLvl 4 ("Fixed parameters: " ++ show params ++ " from " ++ show lhs_in ++

538 "\n" ++ show (fn_ty, fn_is))

539 "\n" ++ show (fn_ty, fn_is))

539

540

540− ((ElabResult lhs' dlhs [] ctxt' newDecls, probs, inj), _) <-

541+ ((ElabResult lhs' dlhs [] ctxt' newDecls highlights, probs, inj), _) <-

541 tclift $ elaborate ctxt (idris_datatypes i) (sMN 0 "patLHS") infP initEState

542 tclift $ elaborate ctxt (idris_datatypes i) (sMN 0 "patLHS") infP initEState

542 (do res <- errAt "left hand side of " fname

543 (do res <- errAt "left hand side of " fname

543 (erun fc (buildTC i info ELHS opts fname (infTerm lhs)))

544 (erun fc (buildTC i info ELHS opts fname (infTerm lhs)))

@@ -546,6 +547,8 @@ elabClause info opts (cnum, PClause fc fname lhs_in_as withs rhs_in_as wherebloc

546 return (res, probs, inj))

547 return (res, probs, inj))

547 setContext ctxt'

548 setContext ctxt'

548 processTacticDecls info newDecls

549 processTacticDecls info newDecls

550+ sendHighlighting highlights

551+

549 when inf $ addTyInfConstraints fc (map (\(x,y,_,_,_,_,_) -> (x,y)) probs)

552 when inf $ addTyInfConstraints fc (map (\(x,y,_,_,_,_,_) -> (x,y)) probs)

550

553

551 let lhs_tm = orderPats (getInferTerm lhs')

554 let lhs_tm = orderPats (getInferTerm lhs')

@@ -612,12 +615,12 @@ elabClause info opts (cnum, PClause fc fname lhs_in_as withs rhs_in_as wherebloc

612 logLvl 2 $ "RHS: " ++ show (map fst newargs_all) ++ " " ++ showTmImpls rhs

615 logLvl 2 $ "RHS: " ++ show (map fst newargs_all) ++ " " ++ showTmImpls rhs

613 ctxt <- getContext -- new context with where block added

616 ctxt <- getContext -- new context with where block added

614 logLvl 5 "STARTING CHECK"

617 logLvl 5 "STARTING CHECK"

615− ((rhs', defer, is, probs, ctxt', newDecls), _) <-

618+ ((rhs', defer, is, probs, ctxt', newDecls, highlights), _) <-

616 tclift $ elaborate ctxt (idris_datatypes i) (sMN 0 "patRHS") clhsty initEState

619 tclift $ elaborate ctxt (idris_datatypes i) (sMN 0 "patRHS") clhsty initEState

617 (do pbinds ist lhs_tm

620 (do pbinds ist lhs_tm

618 mapM_ setinj (nub (params ++ inj))

621 mapM_ setinj (nub (params ++ inj))

619 setNextName

622 setNextName

620− (ElabResult _ _ is ctxt' newDecls) <-

623+ (ElabResult _ _ is ctxt' newDecls highlights) <-

621 errAt "right hand side of " fname

624 errAt "right hand side of " fname

622 (erun fc (build i winfo ERHS opts fname rhs))

625 (erun fc (build i winfo ERHS opts fname rhs))

623 errAt "right hand side of " fname

626 errAt "right hand side of " fname

@@ -629,9 +632,11 @@ elabClause info opts (cnum, PClause fc fname lhs_in_as withs rhs_in_as wherebloc

629 let (tm, ds) = runState (collectDeferred (Just fname)

632 let (tm, ds) = runState (collectDeferred (Just fname)

630 (map fst $ case_decls aux) ctxt tt) []

633 (map fst $ case_decls aux) ctxt tt) []

631 probs <- get_probs

634 probs <- get_probs

632− return (tm, ds, is, probs, ctxt', newDecls))

635+ return (tm, ds, is, probs, ctxt', newDecls, highlights))

633 setContext ctxt'

636 setContext ctxt'

634 processTacticDecls info newDecls

637 processTacticDecls info newDecls

638+ sendHighlighting highlights

639+

635 when inf $ addTyInfConstraints fc (map (\(x,y,_,_,_,_,_) -> (x,y)) probs)

640 when inf $ addTyInfConstraints fc (map (\(x,y,_,_,_,_,_) -> (x,y)) probs)

636

641

637 logLvl 5 "DONE CHECK"

642 logLvl 5 "DONE CHECK"

@@ -727,7 +732,7 @@ elabClause info opts (cnum, PClause fc fname lhs_in_as withs rhs_in_as wherebloc

727-- = NS (UN ('#':show x)) [show cnum, show fname]

732-- = NS (UN ('#':show x)) [show cnum, show fname]

728

733

729 sepBlocks bs = sepBlocks' [] bs where

734 sepBlocks bs = sepBlocks' [] bs where

730− sepBlocks' ns (d@(PTy _ _ _ _ _ n t) : bs)

735+ sepBlocks' ns (d@(PTy _ _ _ _ _ n _ t) : bs)

731 = let (bf, af) = sepBlocks' (n : ns) bs in

736 = let (bf, af) = sepBlocks' (n : ns) bs in

732 (d : bf, af)

737 (d : bf, af)

733 sepBlocks' ns (d@(PClauses _ _ n _) : bs)

738 sepBlocks' ns (d@(PClauses _ _ n _) : bs)

@@ -774,12 +779,14 @@ elabClause info opts (_, PWith fc fname lhs_in withs wval_in pn_in withblock)

774 let params = getParamsInType i [] fn_is fn_ty

779 let params = getParamsInType i [] fn_is fn_ty

775 let lhs = stripLinear i $ stripUnmatchable i $ propagateParams i params fn_ty (addImplPat i lhs_in)

780 let lhs = stripLinear i $ stripUnmatchable i $ propagateParams i params fn_ty (addImplPat i lhs_in)

776 logLvl 2 ("LHS: " ++ show lhs)

781 logLvl 2 ("LHS: " ++ show lhs)

777− (ElabResult lhs' dlhs [] ctxt' newDecls, _) <-

782+ (ElabResult lhs' dlhs [] ctxt' newDecls highlights, _) <-

778 tclift $ elaborate ctxt (idris_datatypes i) (sMN 0 "patLHS") infP initEState

783 tclift $ elaborate ctxt (idris_datatypes i) (sMN 0 "patLHS") infP initEState

779 (errAt "left hand side of with in " fname

784 (errAt "left hand side of with in " fname

780 (erun fc (buildTC i info ELHS opts fname (infTerm lhs))) )

785 (erun fc (buildTC i info ELHS opts fname (infTerm lhs))) )

781 setContext ctxt'

786 setContext ctxt'

782 processTacticDecls info newDecls

787 processTacticDecls info newDecls

788+ sendHighlighting highlights

789+

783 let lhs_tm = orderPats (getInferTerm lhs')

790 let lhs_tm = orderPats (getInferTerm lhs')

784 let lhs_ty = getInferType lhs'

791 let lhs_ty = getInferType lhs'

785 let ret_ty = getRetTy (explicitNames (normalise ctxt [] lhs_ty))

792 let ret_ty = getRetTy (explicitNames (normalise ctxt [] lhs_ty))

@@ -791,19 +798,21 @@ elabClause info opts (_, PWith fc fname lhs_in withs wval_in pn_in withblock)

791 let wval = addImplBound i (map fst bargs) wval_in

798 let wval = addImplBound i (map fst bargs) wval_in

792 logLvl 5 ("Checking " ++ showTmImpls wval)

799 logLvl 5 ("Checking " ++ showTmImpls wval)

793 -- Elaborate wval in this context

800 -- Elaborate wval in this context

794− ((wval', defer, is, ctxt', newDecls), _) <-

801+ ((wval', defer, is, ctxt', newDecls, highlights), _) <-

795 tclift $ elaborate ctxt (idris_datatypes i) (sMN 0 "withRHS")

802 tclift $ elaborate ctxt (idris_datatypes i) (sMN 0 "withRHS")

796 (bindTyArgs PVTy bargs infP) initEState

803 (bindTyArgs PVTy bargs infP) initEState

797 (do pbinds i lhs_tm

804 (do pbinds i lhs_tm

798 setNextName

805 setNextName

799 -- TODO: may want where here - see winfo abpve

806 -- TODO: may want where here - see winfo abpve

800− (ElabResult _ d is ctxt' newDecls) <- errAt "with value in " fname

807+ (ElabResult _ d is ctxt' newDecls highlights) <- errAt "with value in " fname

801 (erun fc (build i info ERHS opts fname (infTerm wval)))

808 (erun fc (build i info ERHS opts fname (infTerm wval)))

802 erun fc $ psolve lhs_tm

809 erun fc $ psolve lhs_tm

803 tt <- get_term

810 tt <- get_term

804− return (tt, d, is, ctxt', newDecls))

811+ return (tt, d, is, ctxt', newDecls, highlights))

805 setContext ctxt'

812 setContext ctxt'

806 processTacticDecls info newDecls

813 processTacticDecls info newDecls

814+ sendHighlighting highlights

815+

807 def' <- checkDef fc iderr defer

816 def' <- checkDef fc iderr defer

808 let def'' = map (\(n, (i, top, t)) -> (n, (i, top, t, False))) def'

817 let def'' = map (\(n, (i, top, t)) -> (n, (i, top, t, False))) def'

809 addDeferred def''

818 addDeferred def''

@@ -828,7 +837,10 @@ elabClause info opts (_, PWith fc fname lhs_in withs wval_in pn_in withblock)

828

837

829 let mpn = case pn_in of

838 let mpn = case pn_in of

830 Nothing -> Nothing

839 Nothing -> Nothing

831− Just n -> Just (uniqueName n (map fst bargs))

840+ Just (n, nfc) -> Just (uniqueName n (map fst bargs))

841+

842+ -- Highlight explicit proofs

843+ sendHighlighting $ [(fc, AnnBoundName n False) | (n, fc) <- maybeToList pn_in]

832

844

833 logLvl 10 ("With type " ++ show (getRetTy cwvaltyN) ++

845 logLvl 10 ("With type " ++ show (getRetTy cwvaltyN) ++

834 " depends on " ++ show pdeps ++ " from " ++ show pvars)

846 " depends on " ++ show pdeps ++ " from " ++ show pvars)

@@ -889,16 +901,18 @@ elabClause info opts (_, PWith fc fname lhs_in withs wval_in pn_in withblock)

889 logLvl 5 ("New RHS " ++ showTmImpls rhs)

901 logLvl 5 ("New RHS " ++ showTmImpls rhs)

890 ctxt <- getContext -- New context with block added

902 ctxt <- getContext -- New context with block added

891 i <- getIState

903 i <- getIState

892− ((rhs', defer, is, ctxt', newDecls), _) <-

904+ ((rhs', defer, is, ctxt', newDecls, highlights), _) <-

893 tclift $ elaborate ctxt (idris_datatypes i) (sMN 0 "wpatRHS") clhsty initEState

905 tclift $ elaborate ctxt (idris_datatypes i) (sMN 0 "wpatRHS") clhsty initEState

894 (do pbinds i lhs_tm

906 (do pbinds i lhs_tm

895 setNextName

907 setNextName

908+ (ElabResult _ d is ctxt' newDecls highlights) <-

896− (ElabResult _ d is ctxt' newDecls) <- erun fc (build i info ERHS opts fname rhs)

909+ erun fc (build i info ERHS opts fname rhs)

897 psolve lhs_tm

910 psolve lhs_tm

898 tt <- get_term

911 tt <- get_term

899− return (tt, d, is, ctxt', newDecls))

912+ return (tt, d, is, ctxt', newDecls, highlights))

900 setContext ctxt'

913 setContext ctxt'

901 processTacticDecls info newDecls

914 processTacticDecls info newDecls

915+ sendHighlighting highlights

902

916

903 def' <- checkDef fc iderr defer

917 def' <- checkDef fc iderr defer

904 let def'' = map (\(n, (i, top, t)) -> (n, (i, top, t, False))) def'

918 let def'' = map (\(n, (i, top, t)) -> (n, (i, top, t, False))) def'

src/Idris/Elab/Data.hs+31−25

@@ -15,7 +15,7 @@ import Idris.Primitives

15import Idris.Inliner

16import Idris.PartialEval

17import Idris.DeepSeq

18−import Idris.Output (iputStrLn, pshow, iWarn)

18+import Idris.Output (iputStrLn, pshow, iWarn, sendHighlighting)

19import IRTS.Lang

21import Idris.Elab.Type

@@ -51,7 +51,7 @@ import Data.List.Split (splitOn)

51import Util.Pretty(pretty, text)

53elabData :: ElabInfo -> SyntaxInfo -> Docstring (Either Err PTerm)-> [(Name, Docstring (Either Err PTerm))] -> FC -> DataOpts -> PData -> Idris ()

54−elabData info syn doc argDocs fc opts (PLaterdecl n t_in)

54+elabData info syn doc argDocs fc opts (PLaterdecl n nfc t_in)

55 = do let codata = Codata `elem` opts

56 iLOG (show (fc, doc))

57 checkUndefined fc n

@@ -59,8 +59,9 @@ elabData info syn doc argDocs fc opts (PLaterdecl n t_in)

60 addIBC (IBCDef n)

61 updateContext (addTyDecl n (TCon 0 0) cty) -- temporary, to check cons

62+ sendHighlighting [(nfc, AnnName n Nothing Nothing Nothing)]

63−elabData info syn doc argDocs fc opts (PDatadecl n t_in dcons)

64+elabData info syn doc argDocs fc opts (PDatadecl n nfc t_in dcons)

64 = do let codata = Codata `elem` opts

65 = do let codata = Codata `elem` opts

65 iLOG (show fc)

66 iLOG (show fc)

66 undef <- isUndefined fc n

67 undef <- isUndefined fc n

@@ -116,6 +117,11 @@ elabData info syn doc argDocs fc opts (PDatadecl n t_in dcons)

116 -- create a case function

117 -- create a case function

117 when (DefaultCaseFun `elem` opts) $

118 when (DefaultCaseFun `elem` opts) $

118 evalStateT (elabCaseFun False params n t dcons info) Map.empty

119 evalStateT (elabCaseFun False params n t dcons info) Map.empty

120+ -- Emit highlighting info

121+ sendHighlighting $ [(nfc, AnnName n Nothing Nothing Nothing)] ++

122+ map (\(_, _, n, nfc, _, _, _) ->

123+ (nfc, AnnName n Nothing Nothing Nothing))

124+ dcons

119 where

125 where

120 setDetaggable :: Name -> Idris ()

126 setDetaggable :: Name -> Idris ()

121 setDetaggable n = do

127 setDetaggable n = do

@@ -194,7 +200,7 @@ elabData info syn doc argDocs fc opts (PDatadecl n t_in dcons)

194 | otherwise = count n ts

200 | otherwise = count n ts

195 mParam args (_ : rest) = Nothing : mParam args rest

201 mParam args (_ : rest) = Nothing : mParam args rest

196

202

197− cname (_, _, n, _, _, _) = n

203+ cname (_, _, n, _, _, _, _) = n

198

204

199 -- Abuse of ElabInfo.

205 -- Abuse of ElabInfo.

200 -- TODO Contemplate whether the ElabInfo type needs modification.

206 -- TODO Contemplate whether the ElabInfo type needs modification.

@@ -212,9 +218,9 @@ elabData info syn doc argDocs fc opts (PDatadecl n t_in dcons)

212elabCon :: ElabInfo -> SyntaxInfo -> Name -> Bool ->

218elabCon :: ElabInfo -> SyntaxInfo -> Name -> Bool ->

213 Type -> -- for unique kind checking

219 Type -> -- for unique kind checking

214 Type -> -- data type's kind

220 Type -> -- data type's kind

215− (Docstring (Either Err PTerm), [(Name, Docstring (Either Err PTerm))], Name, PTerm, FC, [Name]) ->

221+ (Docstring (Either Err PTerm), [(Name, Docstring (Either Err PTerm))], Name, FC, PTerm, FC, [Name]) ->

216 Idris (Name, Type)

222 Idris (Name, Type)

217−elabCon info syn tn codata expkind dkind (doc, argDocs, n, t_in, fc, forcenames)

223+elabCon info syn tn codata expkind dkind (doc, argDocs, n, nfc, t_in, fc, forcenames)

218 = do checkUndefined fc n

224 = do checkUndefined fc n

219 logLvl 2 $ show fc ++ ":Constructor " ++ show n ++ " : " ++ show t_in

225 logLvl 2 $ show fc ++ ":Constructor " ++ show n ++ " : " ++ show t_in

220 (cty, ckind, t, inacc) <- buildType info syn fc [Constructor] n (if codata then mkLazy t_in else t_in)

226 (cty, ckind, t, inacc) <- buildType info syn fc [Constructor] n (if codata then mkLazy t_in else t_in)

@@ -251,13 +257,13 @@ elabCon info syn tn codata expkind dkind (doc, argDocs, n, t_in, fc, forcenames)

251 else return ()

257 else return ()

252 tyIs con t = tclift $ tfail (At fc (Elaborating "constructor " con (Msg (show t ++ " is not " ++ show tn))))

258 tyIs con t = tclift $ tfail (At fc (Elaborating "constructor " con (Msg (show t ++ " is not " ++ show tn))))

253

259

254− mkLazy (PPi pl n ty sc)

260+ mkLazy (PPi pl n nfc ty sc)

255 = let ty' = if getTyName ty

261 = let ty' = if getTyName ty

256 then PApp fc (PRef fc (sUN "Lazy'"))

262 then PApp fc (PRef fc (sUN "Lazy'"))

257 [pexp (PRef fc (sUN "LazyCodata")),

263 [pexp (PRef fc (sUN "LazyCodata")),

258 pexp ty]

264 pexp ty]

259 else ty in

265 else ty in

260− PPi pl n ty' (mkLazy sc)

266+ PPi pl n nfc ty' (mkLazy sc)

261 mkLazy t = t

267 mkLazy t = t

262

268

263 getTyName (PApp _ (PRef _ n) _) = n == nsroot tn

269 getTyName (PApp _ (PRef _ n) _) = n == nsroot tn

@@ -266,8 +272,8 @@ elabCon info syn tn codata expkind dkind (doc, argDocs, n, t_in, fc, forcenames)

266

272

267

273

268 getNamePos :: Int -> PTerm -> Name -> Maybe Int

274 getNamePos :: Int -> PTerm -> Name -> Maybe Int

269− getNamePos i (PPi _ n _ sc) x | n == x = Just i

275+ getNamePos i (PPi _ n _ _ sc) x | n == x = Just i

270− | otherwise = getNamePos (i + 1) sc x

276+ | otherwise = getNamePos (i + 1) sc x

271 getNamePos _ _ _ = Nothing

277 getNamePos _ _ _ = Nothing

272

278

273 -- if the constructor is a UniqueType, the datatype must be too

279 -- if the constructor is a UniqueType, the datatype must be too

@@ -302,17 +308,17 @@ type EliminatorState = StateT (Map.Map String Int) Idris

302-- FIXME: Many things have name starting with elim internally since this was the only purpose in the first edition of the function

308-- FIXME: Many things have name starting with elim internally since this was the only purpose in the first edition of the function

303-- rename to caseFun to match updated intend

309-- rename to caseFun to match updated intend

304elabCaseFun :: Bool -> [Int] -> Name -> PTerm ->

310elabCaseFun :: Bool -> [Int] -> Name -> PTerm ->

305− [(Docstring (Either Err PTerm), [(Name, Docstring (Either Err PTerm))], Name, PTerm, FC, [Name])] ->

311+ [(Docstring (Either Err PTerm), [(Name, Docstring (Either Err PTerm))], Name, FC, PTerm, FC, [Name])] ->

306 ElabInfo -> EliminatorState ()

312 ElabInfo -> EliminatorState ()

307elabCaseFun ind paramPos n ty cons info = do

313elabCaseFun ind paramPos n ty cons info = do

308 elimLog $ "Elaborating case function"

314 elimLog $ "Elaborating case function"

309− put (Map.fromList $ zip (concatMap (\(_, p, _, ty, _, _) -> (map show $ boundNamesIn ty) ++ map (show . fst) p) cons ++ (map show $ boundNamesIn ty)) (repeat 0))

315+ put (Map.fromList $ zip (concatMap (\(_, p, _, _, ty, _, _) -> (map show $ boundNamesIn ty) ++ map (show . fst) p) cons ++ (map show $ boundNamesIn ty)) (repeat 0))

310 let (cnstrs, _) = splitPi ty

316 let (cnstrs, _) = splitPi ty

311 let (splittedTy@(pms, idxs)) = splitPms cnstrs

317 let (splittedTy@(pms, idxs)) = splitPms cnstrs

312 generalParams <- namePis False pms

318 generalParams <- namePis False pms

313 motiveIdxs <- namePis False idxs

319 motiveIdxs <- namePis False idxs

314 let motive = mkMotive n paramPos generalParams motiveIdxs

320 let motive = mkMotive n paramPos generalParams motiveIdxs

315− consTerms <- mapM (\(c@(_, _, cnm, _, _, _)) -> do

321+ consTerms <- mapM (\(c@(_, _, cnm, _, _, _, _)) -> do

316 let casefunt = if ind then "elim_" else "case_"

322 let casefunt = if ind then "elim_" else "case_"

317 name <- freshName $ casefunt ++ simpleName cnm

323 name <- freshName $ casefunt ++ simpleName cnm

318 consTerm <- extractConsTerm c generalParams

324 consTerm <- extractConsTerm c generalParams

@@ -321,7 +327,7 @@ elabCaseFun ind paramPos n ty cons info = do

321 let motiveConstr = [(motiveName, expl, motive)]

327 let motiveConstr = [(motiveName, expl, motive)]

322 let scrutinee = (scrutineeName, expl, applyCons n (interlievePos paramPos generalParams scrutineeIdxs 0))

328 let scrutinee = (scrutineeName, expl, applyCons n (interlievePos paramPos generalParams scrutineeIdxs 0))

323 let eliminatorTy = piConstr (generalParams ++ motiveConstr ++ consTerms ++ scrutineeIdxs ++ [scrutinee]) (applyMotive (map (\(n,_,_) -> PRef elimFC n) scrutineeIdxs) (PRef elimFC scrutineeName))

329 let eliminatorTy = piConstr (generalParams ++ motiveConstr ++ consTerms ++ scrutineeIdxs ++ [scrutinee]) (applyMotive (map (\(n,_,_) -> PRef elimFC n) scrutineeIdxs) (PRef elimFC scrutineeName))

324− let eliminatorTyDecl = PTy (fmap (const (Left $ Msg "")) . parseDocstring . T.pack $ show n) [] defaultSyntax elimFC [TotalFn] elimDeclName eliminatorTy

330+ let eliminatorTyDecl = PTy (fmap (const (Left $ Msg "")) . parseDocstring . T.pack $ show n) [] defaultSyntax elimFC [TotalFn] elimDeclName NoFC eliminatorTy

325 let clauseConsElimArgs = map getPiName consTerms

331 let clauseConsElimArgs = map getPiName consTerms

326 let clauseGeneralArgs' = map getPiName generalParams ++ [motiveName] ++ clauseConsElimArgs

332 let clauseGeneralArgs' = map getPiName generalParams ++ [motiveName] ++ clauseConsElimArgs

327 let clauseGeneralArgs = map (\arg -> pexp (PRef elimFC arg)) clauseGeneralArgs'

333 let clauseGeneralArgs = map (\arg -> pexp (PRef elimFC arg)) clauseGeneralArgs'

@@ -353,8 +359,8 @@ elabCaseFun ind paramPos n ty cons info = do

353 splitPi :: PTerm -> ([(Name, Plicity, PTerm)], PTerm)

359 splitPi :: PTerm -> ([(Name, Plicity, PTerm)], PTerm)

354 splitPi = splitPi' []

360 splitPi = splitPi' []

355 where splitPi' :: [(Name, Plicity, PTerm)] -> PTerm -> ([(Name, Plicity, PTerm)], PTerm)

361 where splitPi' :: [(Name, Plicity, PTerm)] -> PTerm -> ([(Name, Plicity, PTerm)], PTerm)

356− splitPi' acc (PPi pl n tyl tyr) = splitPi' ((n, pl, tyl):acc) tyr

362+ splitPi' acc (PPi pl n _ tyl tyr) = splitPi' ((n, pl, tyl):acc) tyr

357− splitPi' acc t = (reverse acc, t)

363+ splitPi' acc t = (reverse acc, t)

358

364

359 splitPms :: [(Name, Plicity, PTerm)] -> ([(Name, Plicity, PTerm)], [(Name, Plicity, PTerm)])

365 splitPms :: [(Name, Plicity, PTerm)] -> ([(Name, Plicity, PTerm)], [(Name, Plicity, PTerm)])

360 splitPms cnstrs = (map fst pms, map fst idxs)

366 splitPms cnstrs = (map fst pms, map fst idxs)

@@ -377,7 +383,7 @@ elabCaseFun ind paramPos n ty cons info = do

377 where keyOf :: PTerm -> String

383 where keyOf :: PTerm -> String

378 keyOf (PRef _ name) | isLetter (nameStart name) = (toLower $ nameStart name):"__"

384 keyOf (PRef _ name) | isLetter (nameStart name) = (toLower $ nameStart name):"__"

379 keyOf (PApp _ tyf _) = keyOf tyf

385 keyOf (PApp _ tyf _) = keyOf tyf

380− keyOf PType = "ty__"

386+ keyOf (PType _) = "ty__"

381 keyOf _ = "carg__"

387 keyOf _ = "carg__"

382 nameStart :: Name -> Char

388 nameStart :: Name -> Char

383 nameStart n = nameStart' (simpleName n)

389 nameStart n = nameStart' (simpleName n)

@@ -414,11 +420,11 @@ elabCaseFun ind paramPos n ty cons info = do

414 mkMotive :: Name -> [Int] -> [(Name, Plicity, PTerm)] -> [(Name, Plicity, PTerm)] -> PTerm

420 mkMotive :: Name -> [Int] -> [(Name, Plicity, PTerm)] -> [(Name, Plicity, PTerm)] -> PTerm

415 mkMotive n paramPos params indicies =

421 mkMotive n paramPos params indicies =

416 let scrutineeTy = (scrutineeArgName, expl, applyCons n (interlievePos paramPos params indicies 0))

422 let scrutineeTy = (scrutineeArgName, expl, applyCons n (interlievePos paramPos params indicies 0))

417− in piConstr (indicies ++ [scrutineeTy]) PType

423+ in piConstr (indicies ++ [scrutineeTy]) (PType elimFC)

418

424

419 piConstr :: [(Name, Plicity, PTerm)] -> PTerm -> PTerm

425 piConstr :: [(Name, Plicity, PTerm)] -> PTerm -> PTerm

420 piConstr [] ty = ty

426 piConstr [] ty = ty

421− piConstr ((n, pl, tyb):tyr) ty = PPi pl n tyb (piConstr tyr ty)

427+ piConstr ((n, pl, tyb):tyr) ty = PPi pl n NoFC tyb (piConstr tyr ty)

422

428

423 interlievePos :: [Int] -> [a] -> [a] -> Int -> [a]

429 interlievePos :: [Int] -> [a] -> [a] -> Int -> [a]

424 interlievePos idxs [] l2 i = l2

430 interlievePos idxs [] l2 i = l2

@@ -436,9 +442,9 @@ elabCaseFun ind paramPos n ty cons info = do

436 _ -> cns

442 _ -> cns

437

443

438 removeParamPis :: [Name] -> [(Name, Plicity, PTerm)] -> PTerm -> PTerm

444 removeParamPis :: [Name] -> [(Name, Plicity, PTerm)] -> PTerm -> PTerm

439− removeParamPis oldParams params (PPi pl n tyb tyr) =

445+ removeParamPis oldParams params (PPi pl n fc tyb tyr) =

440 case findIndex (== n) oldParams of

446 case findIndex (== n) oldParams of

441− Nothing -> (PPi pl n (removeParamPis oldParams params tyb) (removeParamPis oldParams params tyr))

447+ Nothing -> (PPi pl n fc (removeParamPis oldParams params tyb) (removeParamPis oldParams params tyr))

442 Just i -> (removeParamPis oldParams params tyr)

448 Just i -> (removeParamPis oldParams params tyr)

443 removeParamPis oldParams params (PRef _ n) =

449 removeParamPis oldParams params (PRef _ n) =

444 case findIndex (== n) oldParams of

450 case findIndex (== n) oldParams of

@@ -488,8 +494,8 @@ elabCaseFun ind paramPos n ty cons info = do

488 in return $ filter (\(n,_,_) -> not (n `elem` oldParams))implargs

494 in return $ filter (\(n,_,_) -> not (n `elem` oldParams))implargs

489 _ -> return implargs

495 _ -> return implargs

490

496

491− extractConsTerm :: (Docstring (Either Err PTerm), [(Name, Docstring (Either Err PTerm))], Name, PTerm, FC, [Name]) -> [(Name, Plicity, PTerm)] -> EliminatorState PTerm

497+ extractConsTerm :: (Docstring (Either Err PTerm), [(Name, Docstring (Either Err PTerm))], Name, FC, PTerm, FC, [Name]) -> [(Name, Plicity, PTerm)] -> EliminatorState PTerm

492− extractConsTerm (doc, argDocs, cnm, ty, fc, fs) generalParameters = do

498+ extractConsTerm (doc, argDocs, cnm, _, ty, fc, fs) generalParameters = do

493 let cons' = replaceParams paramPos generalParameters ty

499 let cons' = replaceParams paramPos generalParameters ty

494 let (args, resTy) = splitPi cons'

500 let (args, resTy) = splitPi cons'

495 implidxs <- implicitIndexes (doc, cnm, ty, fc, fs)

501 implidxs <- implicitIndexes (doc, cnm, ty, fc, fs)

@@ -524,8 +530,8 @@ elabCaseFun ind paramPos n ty cons info = do

524 convertImplPi (PImp {getTm = t, pname = n}) = Just (n, expl, t)

530 convertImplPi (PImp {getTm = t, pname = n}) = Just (n, expl, t)

525 convertImplPi _ = Nothing

531 convertImplPi _ = Nothing

526

532

527− generateEliminatorClauses :: (Docstring (Either Err PTerm), [(Name, Docstring (Either Err PTerm))], Name, PTerm, FC, [Name]) -> Name -> [PArg] -> [(Name, Plicity, PTerm)] -> EliminatorState PClause

533+ generateEliminatorClauses :: (Docstring (Either Err PTerm), [(Name, Docstring (Either Err PTerm))], Name, FC, PTerm, FC, [Name]) -> Name -> [PArg] -> [(Name, Plicity, PTerm)] -> EliminatorState PClause

528− generateEliminatorClauses (doc, _, cnm, ty, fc, fs) cnsElim generalArgs generalParameters = do

534+ generateEliminatorClauses (doc, _, cnm, _, ty, fc, fs) cnsElim generalArgs generalParameters = do

529 let cons' = replaceParams paramPos generalParameters ty

535 let cons' = replaceParams paramPos generalParameters ty

530 let (args, resTy) = splitPi cons'

536 let (args, resTy) = splitPi cons'

531 i <- State.lift getIState

537 i <- State.lift getIState

src/Idris/Elab/Instance.hs+22−20

@@ -14,7 +14,7 @@ import Idris.Primitives

14import Idris.Inliner

15import Idris.PartialEval

16import Idris.DeepSeq

17−import Idris.Output (iputStrLn, pshow, iWarn)

17+import Idris.Output (iputStrLn, pshow, iWarn, sendHighlighting)

18import IRTS.Lang

20import Idris.Elab.Type

@@ -56,11 +56,12 @@ elabInstance :: ElabInfo -> SyntaxInfo ->

56 ElabWhat -> -- phase

57 FC -> [(Name, PTerm)] -> -- constraints

58 Name -> -- the class

59+ FC -> -- precise location of class name

59 [PTerm] -> -- class parameters (i.e. instance)

60 [PTerm] -> -- class parameters (i.e. instance)

60 PTerm -> -- full instance type

61 PTerm -> -- full instance type

61 Maybe Name -> -- explicit name

62 Maybe Name -> -- explicit name

62 [PDecl] -> Idris ()

63 [PDecl] -> Idris ()

63−elabInstance info syn doc argDocs what fc cs n ps t expn ds = do

64+elabInstance info syn doc argDocs what fc cs n nfc ps t expn ds = do

64 i <- getIState

65 i <- getIState

65 (n, ci) <- case lookupCtxtName n (idris_classes i) of

66 (n, ci) <- case lookupCtxtName n (idris_classes i) of

66 [c] -> return c

67 [c] -> return c

@@ -71,7 +72,7 @@ elabInstance info syn doc argDocs what fc cs n ps t expn ds = do

71 let iname = mkiname n (namespace info) ps expn

72 let iname = mkiname n (namespace info) ps expn

72 let emptyclass = null (class_methods ci)

73 let emptyclass = null (class_methods ci)

73 when (what /= EDefns || (null ds && not emptyclass)) $ do

74 when (what /= EDefns || (null ds && not emptyclass)) $ do

74− nty <- elabType' True info syn doc argDocs fc [] iname t

75+ nty <- elabType' True info syn doc argDocs fc [] iname NoFC t

75 -- if the instance type matches any of the instances we have already,

76 -- if the instance type matches any of the instances we have already,

76 -- and it's not a named instance, then it's overlapping, so report an error

77 -- and it's not a named instance, then it's overlapping, so report an error

77 case expn of

78 case expn of

@@ -146,7 +147,7 @@ elabInstance info syn doc argDocs what fc cs n ps t expn ds = do

146

147

147 where

148 where

148 intInst = case ps of

149 intInst = case ps of

149− [PConstant (AType (ATInt ITNative))] -> True

150+ [PConstant NoFC (AType (ATInt ITNative))] -> True

150 _ -> False

151 _ -> False

151

152

152 mkiname n' ns ps' expn' =

153 mkiname n' ns ps' expn' =

@@ -156,10 +157,10 @@ elabInstance info syn doc argDocs what fc cs n ps t expn ds = do

156 Just m -> sNS (SN (sInstanceN n' (map show ps'))) m

157 Just m -> sNS (SN (sInstanceN n' (map show ps'))) m

157 Just nm -> nm

158 Just nm -> nm

158

159

159− substInstance ips pnames (PInstance doc argDocs syn _ cs n ps t expn ds)

160+ substInstance ips pnames (PInstance doc argDocs syn _ cs n nfc ps t expn ds)

160− = PInstance doc argDocs syn fc cs n (map (substMatchesShadow ips pnames) ps) (substMatchesShadow ips pnames t) expn ds

161+ = PInstance doc argDocs syn fc cs n nfc (map (substMatchesShadow ips pnames) ps) (substMatchesShadow ips pnames t) expn ds

161

162

162− isOverlapping i (PInstance doc argDocs syn _ _ n ps t expn _)

163+ isOverlapping i (PInstance doc argDocs syn _ _ n nfc ps t expn _)

163 = case lookupCtxtName n (idris_classes i) of

164 = case lookupCtxtName n (idris_classes i) of

164 [(n, ci)] -> let iname = (mkiname n (namespace info) ps expn) in

165 [(n, ci)] -> let iname = (mkiname n (namespace info) ps expn) in

165 case lookupTy iname (tt_ctxt i) of

166 case lookupTy iname (tt_ctxt i) of

@@ -176,11 +177,12 @@ elabInstance info syn doc argDocs what fc cs n ps t expn ds = do

176 ty' <- implicit info syn iname ty'

177 ty' <- implicit info syn iname ty'

177 let ty = addImpl [] i ty'

178 let ty = addImpl [] i ty'

178 ctxt <- getContext

179 ctxt <- getContext

179− (ElabResult tyT _ _ ctxt' newDecls, _) <-

180+ (ElabResult tyT _ _ ctxt' newDecls highlights, _) <-

180 tclift $ elaborate ctxt (idris_datatypes i) iname (TType (UVal 0)) initEState

181 tclift $ elaborate ctxt (idris_datatypes i) iname (TType (UVal 0)) initEState

181 (errAt "type of " iname (erun fc (build i info ERHS [] iname ty)))

182 (errAt "type of " iname (erun fc (build i info ERHS [] iname ty)))

182 setContext ctxt'

183 setContext ctxt'

183 processTacticDecls info newDecls

184 processTacticDecls info newDecls

185+ sendHighlighting highlights

184 ctxt <- getContext

186 ctxt <- getContext

185 (cty, _) <- recheckC fc id [] tyT

187 (cty, _) <- recheckC fc id [] tyT

186 let nty = normalise ctxt [] cty

188 let nty = normalise ctxt [] cty

@@ -200,7 +202,7 @@ elabInstance info syn doc argDocs what fc cs n ps t expn ds = do

200 _ -> Nothing

202 _ -> Nothing

201 overlapping t' = tclift $ tfail (At fc (Msg $

203 overlapping t' = tclift $ tfail (At fc (Msg $

202 "Overlapping instance: " ++ show t' ++ " already defined"))

204 "Overlapping instance: " ++ show t' ++ " already defined"))

203− getRetType (PPi _ _ _ sc) = getRetType sc

205+ getRetType (PPi _ _ _ _ sc) = getRetType sc

204 getRetType t = t

206 getRetType t = t

205

207

206 matchArgs i dets x y =

208 matchArgs i dets x y =

@@ -215,16 +217,16 @@ elabInstance info syn doc argDocs what fc cs n ps t expn ds = do

215

217

216 mkMethApp (n, _, _, ty)

218 mkMethApp (n, _, _, ty)

217 = lamBind 0 ty (papp fc (PRef fc n) (methArgs 0 ty))

219 = lamBind 0 ty (papp fc (PRef fc n) (methArgs 0 ty))

218− lamBind i (PPi (Constraint _ _) _ _ sc) sc'

220+ lamBind i (PPi (Constraint _ _) _ _ _ sc) sc'

219− = PLam fc (sMN i "meth") Placeholder (lamBind (i+1) sc sc')

221+ = PLam fc (sMN i "meth") NoFC Placeholder (lamBind (i+1) sc sc')

220− lamBind i (PPi _ n ty sc) sc'

222+ lamBind i (PPi _ n _ ty sc) sc'

221− = PLam fc (sMN i "meth") Placeholder (lamBind (i+1) sc sc')

223+ = PLam fc (sMN i "meth") NoFC Placeholder (lamBind (i+1) sc sc')

222 lamBind i _ sc = sc

224 lamBind i _ sc = sc

223− methArgs i (PPi (Imp _ _ _ _) n ty sc)

225+ methArgs i (PPi (Imp _ _ _ _) n _ ty sc)

224 = PImp 0 True [] n (PRef fc (sMN i "meth")) : methArgs (i+1) sc

226 = PImp 0 True [] n (PRef fc (sMN i "meth")) : methArgs (i+1) sc

225− methArgs i (PPi (Exp _ _ _) n ty sc)

227+ methArgs i (PPi (Exp _ _ _) n _ ty sc)

226 = PExp 0 [] (sMN 0 "marg") (PRef fc (sMN i "meth")) : methArgs (i+1) sc

228 = PExp 0 [] (sMN 0 "marg") (PRef fc (sMN i "meth")) : methArgs (i+1) sc

227− methArgs i (PPi (Constraint _ _) n ty sc)

229+ methArgs i (PPi (Constraint _ _) n _ ty sc)

228 = PConstraint 0 [] (sMN 0 "marg") (PResolveTC fc) : methArgs (i+1) sc

230 = PConstraint 0 [] (sMN 0 "marg") (PResolveTC fc) : methArgs (i+1) sc

229 methArgs i _ = []

231 methArgs i _ = []

230

232

@@ -244,16 +246,16 @@ elabInstance info syn doc argDocs what fc cs n ps t expn ds = do

244 decorate ns iname (UN n) = NS (SN (MethodN (UN n))) ns

246 decorate ns iname (UN n) = NS (SN (MethodN (UN n))) ns

245 decorate ns iname (NS (UN n) s) = NS (SN (MethodN (UN n))) ns

247 decorate ns iname (NS (UN n) s) = NS (SN (MethodN (UN n))) ns

246

248

247− mkTyDecl (n, op, t, _)

249+ mkTyDecl (n, op, t, _)

248− = PTy emptyDocstring [] syn fc op n

250+ = PTy emptyDocstring [] syn fc op n NoFC

249 (mkUniqueNames [] t)

251 (mkUniqueNames [] t)

250

252

251 conbind :: [(Name, PTerm)] -> PTerm -> PTerm

253 conbind :: [(Name, PTerm)] -> PTerm -> PTerm

252− conbind ((c,ty) : ns) x = PPi constraint c ty (conbind ns x)

254+ conbind ((c,ty) : ns) x = PPi constraint c NoFC ty (conbind ns x)

253 conbind [] x = x

255 conbind [] x = x

254

256

255 coninsert :: [(Name, PTerm)] -> PTerm -> PTerm

257 coninsert :: [(Name, PTerm)] -> PTerm -> PTerm

256− coninsert cs (PPi p@(Imp _ _ _ _) n t sc) = PPi p n t (coninsert cs sc)

258+ coninsert cs (PPi p@(Imp _ _ _ _) n fc t sc) = PPi p n fc t (coninsert cs sc)

257 coninsert cs sc = conbind cs sc

259 coninsert cs sc = conbind cs sc

258

260

259 -- Reorder declarations to be in the same order as defined in the

261 -- Reorder declarations to be in the same order as defined in the

src/Idris/Elab/Provider.hs+2−2

@@ -66,7 +66,7 @@ elabProvider doc info syn fc what n

66 -- The goal type for a postulate is always Type.

67 (ty', typ) <- case what of

68 ProvTerm ty p -> elabVal info ERHS ty

69− ProvPostulate _ -> elabVal info ERHS PType

69+ ProvPostulate _ -> elabVal info ERHS (PType fc)

70 unless (isTType typ) $

71 ifail ("Expected a type, got " ++ show ty' ++ " : " ++ show typ)

@@ -93,7 +93,7 @@ elabProvider doc info syn fc what n

93 Provide tm

94 | ProvTerm ty _ <- what ->

95 do -- Finally add a top-level definition of the provided term

96− elabType info syn doc [] fc [] n ty

96+ elabType info syn doc [] fc [] n NoFC ty

97 elabClauses info fc [] n [PClause fc n (PApp fc (PRef fc n) []) [] (delab i tm) []]

98 logLvl 3 $ "Elaborated provider " ++ show n ++ " as: " ++ show tm

99 | ProvPostulate _ <- what ->

src/Idris/Elab/Record.hs+61−50

@@ -14,7 +14,7 @@ import Idris.Primitives

14import Idris.Inliner

15import Idris.PartialEval

16import Idris.DeepSeq

17−import Idris.Output (iputStrLn, pshow, iWarn)

17+import Idris.Output (iputStrLn, pshow, iWarn, sendHighlighting)

18import IRTS.Lang

20import Idris.ParseExpr (tryFullExpr)

@@ -37,37 +37,44 @@ elabRecord :: ElabInfo

37 -> (Docstring (Either Err PTerm)) -- ^ The documentation for the whole declaration

38 -> SyntaxInfo -> FC -> DataOpts

39 -> Name -- ^ The name of the type being defined

40+ -> FC -- ^ The precise source location of the tycon name

40− -> [(Name, Plicity, PTerm)] -- ^ Parameters

41+ -> [(Name, FC, Plicity, PTerm)] -- ^ Parameters

41 -> [(Name, Docstring (Either Err PTerm))] -- ^ Parameter Docs

42 -> [(Name, Docstring (Either Err PTerm))] -- ^ Parameter Docs

42− -> [((Maybe Name), Plicity, PTerm, Maybe (Docstring (Either Err PTerm)))] -- ^ Fields

43+ -> [(Maybe (Name, FC), Plicity, PTerm, Maybe (Docstring (Either Err PTerm)))] -- ^ Fields

43− -> Maybe Name -- ^ Constructor Name

44+ -> Maybe (Name, FC) -- ^ Constructor Name

44 -> (Docstring (Either Err PTerm)) -- ^ Constructor Doc

45 -> (Docstring (Either Err PTerm)) -- ^ Constructor Doc

45 -> SyntaxInfo -- ^ Constructor SyntaxInfo

46 -> SyntaxInfo -- ^ Constructor SyntaxInfo

46 -> Idris ()

47 -> Idris ()

47−elabRecord info doc rsyn fc opts tyn params paramDocs fields cname cdoc csyn

48+elabRecord info doc rsyn fc opts tyn nfc params paramDocs fields cname cdoc csyn

48 = do logLvl 1 $ "Building data declaration for " ++ show tyn

49 = do logLvl 1 $ "Building data declaration for " ++ show tyn

49 -- Type constructor

50 -- Type constructor

50 let tycon = generateTyConType params

51 let tycon = generateTyConType params

51 logLvl 1 $ "Type constructor " ++ showTmImpls tycon

52 logLvl 1 $ "Type constructor " ++ showTmImpls tycon

53 -- Data constructor

54 -- Data constructor

54− dconName <- generateDConName cname

55+ dconName <- generateDConName (fmap fst cname)

55 let dconTy = generateDConType params fieldsWithNameAndDoc

56 let dconTy = generateDConType params fieldsWithNameAndDoc

56 logLvl 1 $ "Data constructor: " ++ showTmImpls dconTy

57 logLvl 1 $ "Data constructor: " ++ showTmImpls dconTy

58 -- Build data declaration for elaboration

59 -- Build data declaration for elaboration

59 iLOG $ foldr (++) "" $ intersperse "\n" (map show dconsArgDocs)

60 iLOG $ foldr (++) "" $ intersperse "\n" (map show dconsArgDocs)

60− let datadecl = PDatadecl tyn tycon [(cdoc, dconsArgDocs, dconName, dconTy, fc, [])]

61+ let datadecl = PDatadecl tyn NoFC tycon [(cdoc, dconsArgDocs, dconName, NoFC, dconTy, fc, [])]

61 elabData info rsyn doc paramDocs fc opts datadecl

62 elabData info rsyn doc paramDocs fc opts datadecl

63 iLOG $ "fieldsWithName " ++ show fieldsWithName

64 iLOG $ "fieldsWithName " ++ show fieldsWithName

64 iLOG $ "fieldsWIthNameAndDoc " ++ show fieldsWithNameAndDoc

65 iLOG $ "fieldsWIthNameAndDoc " ++ show fieldsWithNameAndDoc

65 elabRecordFunctions info rsyn fc tyn paramsAndDoc fieldsWithNameAndDoc dconName target

66 elabRecordFunctions info rsyn fc tyn paramsAndDoc fieldsWithNameAndDoc dconName target

67+

68+ sendHighlighting $

69+ [(nfc, AnnName tyn Nothing Nothing Nothing)] ++

70+ maybe [] (\(_, cnfc) -> [(cnfc, AnnName dconName Nothing Nothing Nothing)]) cname ++

71+ [(ffc, AnnBoundName fn False) | (fn, ffc, _, _, _) <- fieldsWithName]

72+

66 where

73 where

67 -- | Generates a type constructor.

74 -- | Generates a type constructor.

68− generateTyConType :: [(Name, Plicity, PTerm)] -> PTerm

75+ generateTyConType :: [(Name, FC, Plicity, PTerm)] -> PTerm

69− generateTyConType ((n, p, t) : rest) = PPi p (nsroot n) t (generateTyConType rest)

76+ generateTyConType ((n, nfc, p, t) : rest) = PPi p (nsroot n) nfc t (generateTyConType rest)

70− generateTyConType [] = PType

77+ generateTyConType [] = (PType fc)

72 -- | Generates a name for the data constructor if none was specified.

79 -- | Generates a name for the data constructor if none was specified.

73 generateDConName :: Maybe Name -> Idris Name

80 generateDConName :: Maybe Name -> Idris Name

@@ -81,65 +88,66 @@ elabRecord info doc rsyn fc opts tyn params paramDocs fields cname cdoc csyn

81 Nothing -> return n

88 Nothing -> return n

83 -- | Generates the data constructor type.

90 -- | Generates the data constructor type.

84− generateDConType :: [(Name, Plicity, PTerm)] -> [(Name, Plicity, PTerm, a)] -> PTerm

91+ generateDConType :: [(Name, FC, Plicity, PTerm)] -> [(Name, FC, Plicity, PTerm, a)] -> PTerm

85− generateDConType ((n, _, t) : ps) as = PPi impl (nsroot n) t (generateDConType ps as)

92+ generateDConType ((n, nfc, _, t) : ps) as = PPi impl (nsroot n) NoFC t (generateDConType ps as)

86− generateDConType [] ((n, p, t, _) : as) = PPi p (nsroot n) t (generateDConType [] as)

93+ generateDConType [] ((n, _, p, t, _) : as) = PPi p (nsroot n) NoFC t (generateDConType [] as)

87 generateDConType [] [] = target

94 generateDConType [] [] = target

89 -- | The target for the constructor and projection functions. Also the source of the update functions.

96 -- | The target for the constructor and projection functions. Also the source of the update functions.

90 target :: PTerm

97 target :: PTerm

91− target = PApp fc (PRef fc tyn) $ map (uncurry asPRefArg) [(p, n) | (n, p, _) <- params]

98+ target = PApp fc (PRef fc tyn) $ map (uncurry asPRefArg) [(p, n) | (n, _, p, _) <- params]

93− paramsAndDoc :: [(Name, Plicity, PTerm, Docstring (Either Err PTerm))]

100+ paramsAndDoc :: [(Name, FC, Plicity, PTerm, Docstring (Either Err PTerm))]

94 paramsAndDoc = pad params paramDocs

101 paramsAndDoc = pad params paramDocs

95 where

102 where

96− pad :: [(Name, Plicity, PTerm)] -> [(Name, Docstring (Either Err PTerm))] -> [(Name, Plicity, PTerm, Docstring (Either Err PTerm))]

103+ pad :: [(Name, FC, Plicity, PTerm)] -> [(Name, Docstring (Either Err PTerm))] -> [(Name, FC, Plicity, PTerm, Docstring (Either Err PTerm))]

97− pad ((n, p, t) : rest) docs

104+ pad ((n, fc, p, t) : rest) docs

98 = let d = case lookup n docs of

105 = let d = case lookup n docs of

99 Just d' -> d

106 Just d' -> d

100 Nothing -> emptyDocstring

107 Nothing -> emptyDocstring

101− in (n, p, t, d) : (pad rest docs)

108+ in (n, fc, p, t, d) : (pad rest docs)

102 pad _ _ = []

109 pad _ _ = []

103

110

104 dconsArgDocs :: [(Name, Docstring (Either Err PTerm))]

111 dconsArgDocs :: [(Name, Docstring (Either Err PTerm))]

105 dconsArgDocs = paramDocs ++ (dcad fieldsWithName)

112 dconsArgDocs = paramDocs ++ (dcad fieldsWithName)

106 where

113 where

107− dcad :: [(Name, Plicity, PTerm, Maybe (Docstring (Either Err PTerm)))] -> [(Name, Docstring (Either Err PTerm))]

114+ dcad :: [(Name, FC, Plicity, PTerm, Maybe (Docstring (Either Err PTerm)))] -> [(Name, Docstring (Either Err PTerm))]

108− dcad ((n, _, _, (Just d)) : rest) = ((nsroot n), d) : (dcad rest)

115+ dcad ((n, _, _, _, (Just d)) : rest) = ((nsroot n), d) : (dcad rest)

109 dcad (_ : rest) = dcad rest

116 dcad (_ : rest) = dcad rest

110 dcad [] = []

117 dcad [] = []

111

118

112− fieldsWithName :: [(Name, Plicity, PTerm, Maybe (Docstring (Either Err PTerm)))]

119+ fieldsWithName :: [(Name, FC, Plicity, PTerm, Maybe (Docstring (Either Err PTerm)))]

113 fieldsWithName = fwn [] fields

120 fieldsWithName = fwn [] fields

114 where

121 where

115− fwn :: [Name] -> [(Maybe Name, Plicity, PTerm, Maybe (Docstring (Either Err PTerm)))] -> [(Name, Plicity, PTerm, Maybe (Docstring (Either Err PTerm)))]

122+ fwn :: [Name] -> [(Maybe (Name, FC), Plicity, PTerm, Maybe (Docstring (Either Err PTerm)))] -> [(Name, FC, Plicity, PTerm, Maybe (Docstring (Either Err PTerm)))]

116 fwn ns ((n, p, t, d) : rest)

123 fwn ns ((n, p, t, d) : rest)

117 = let nn = case n of

124 = let nn = case n of

118 Just n' -> n'

125 Just n' -> n'

119 Nothing -> newName ns baseName

126 Nothing -> newName ns baseName

127+ withNS = expandNS rsyn (fst nn)

120− in (expandNS rsyn $ nn, p, t, d) : (fwn (nn : ns) rest)

128+ in (withNS, snd nn, p, t, d) : (fwn (fst nn : ns) rest)

121 fwn _ _ = []

129 fwn _ _ = []

122

130

123− baseName = sUN "__pi_arg"

131+ baseName = (sUN "__pi_arg", NoFC)

132+

133+ newName :: [Name] -> (Name, FC) -> (Name, FC)

134+ newName ns (n, nfc)

135+ | n `elem` ns = newName ns (nextName n, nfc)

136+ | otherwise = (n, nfc)

124

137

125− newName :: [Name] -> Name -> Name

126− newName ns n

127− | n `elem` ns = newName ns (nextName n)

128− | otherwise = n

129−

130− fieldsWithNameAndDoc :: [(Name, Plicity, PTerm, Docstring (Either Err PTerm))]

138+ fieldsWithNameAndDoc :: [(Name, FC, Plicity, PTerm, Docstring (Either Err PTerm))]

131 fieldsWithNameAndDoc = fwnad fieldsWithName

139 fieldsWithNameAndDoc = fwnad fieldsWithName

132 where

140 where

133− fwnad :: [(Name, Plicity, PTerm, Maybe (Docstring (Either Err PTerm)))] -> [(Name, Plicity, PTerm, Docstring (Either Err PTerm))]

141+ fwnad :: [(Name, FC, Plicity, PTerm, Maybe (Docstring (Either Err PTerm)))] -> [(Name, FC, Plicity, PTerm, Docstring (Either Err PTerm))]

134− fwnad ((n, p, t, d) : rest)

142+ fwnad ((n, nfc, p, t, d) : rest)

135 = let doc = fromMaybe emptyDocstring d

143 = let doc = fromMaybe emptyDocstring d

136− in (n, p, t, doc) : (fwnad rest)

144+ in (n, nfc, p, t, doc) : (fwnad rest)

137 fwnad [] = []

145 fwnad [] = []

138

146

139elabRecordFunctions :: ElabInfo -> SyntaxInfo -> FC

147elabRecordFunctions :: ElabInfo -> SyntaxInfo -> FC

140 -> Name -- ^ Record type name

148 -> Name -- ^ Record type name

141− -> [(Name, Plicity, PTerm, Docstring (Either Err PTerm))] -- ^ Parameters

149+ -> [(Name, FC, Plicity, PTerm, Docstring (Either Err PTerm))] -- ^ Parameters

142− -> [(Name, Plicity, PTerm, Docstring (Either Err PTerm))] -- ^ Fields

150+ -> [(Name, FC, Plicity, PTerm, Docstring (Either Err PTerm))] -- ^ Fields

143 -> Name -- ^ Constructor Name

151 -> Name -- ^ Constructor Name

144 -> PTerm -- ^ Target type

152 -> PTerm -- ^ Target type

145 -> Idris ()

153 -> Idris ()

@@ -149,7 +157,7 @@ elabRecordFunctions info rsyn fc tyn params fields dconName target

149 iLOG $ "Fields: " ++ show fieldNames

157 iLOG $ "Fields: " ++ show fieldNames

150 iLOG $ "Params: " ++ show paramNames

158 iLOG $ "Params: " ++ show paramNames

151 -- The elaborated constructor type for the data declaration

159 -- The elaborated constructor type for the data declaration

152− i <- getIState

160+ i <- getIState

153 ttConsTy <-

161 ttConsTy <-

154 case lookupTyExact dconName (tt_ctxt i) of

162 case lookupTyExact dconName (tt_ctxt i) of

155 Just as -> return as

163 Just as -> return as

@@ -164,11 +172,11 @@ elabRecordFunctions info rsyn fc tyn params fields dconName target

164

172

165 -- The parameters for elaboration with their documentation

173 -- The parameters for elaboration with their documentation

166 -- Parameter functions are all prefixed with "param_".

174 -- Parameter functions are all prefixed with "param_".

167− let paramsForElab = [((nsroot n), (paramName n), impl, t, d) | (n, _, t, d) <- params] -- zipParams i params paramDocs]

175+ let paramsForElab = [((nsroot n), (paramName n), impl, t, d) | (n, _, _, t, d) <- params] -- zipParams i params paramDocs]

168−

176+

169 -- The fields (written by the user) with their documentation.

177 -- The fields (written by the user) with their documentation.

170− let userFieldsForElab = [((nsroot n), n, p, t, d) | (n, p, t, d) <- fields]

178+ let userFieldsForElab = [((nsroot n), n, p, t, d) | (n, nfc, p, t, d) <- fields]

171−

179+

172 -- All things we need to elaborate projection functions for, together with a number denoting their position in the constructor.

180 -- All things we need to elaborate projection functions for, together with a number denoting their position in the constructor.

173 let projectors = [(n, n', p, t, d, i) | ((n, n', p, t, d), i) <- zip (freeFieldsForElab ++ paramsForElab ++ userFieldsForElab) [0..]]

181 let projectors = [(n, n', p, t, d, i) | ((n, n', p, t, d), i) <- zip (freeFieldsForElab ++ paramsForElab ++ userFieldsForElab) [0..]]

174 -- Build and elaborate projection functions

182 -- Build and elaborate projection functions

@@ -189,10 +197,10 @@ elabRecordFunctions info rsyn fc tyn params fields dconName target

189

197

190 -- | Root names of all fields in the current record declarations

198 -- | Root names of all fields in the current record declarations

191 fieldNames :: [Name]

199 fieldNames :: [Name]

192− fieldNames = [nsroot n | (n, _, _, _) <- fields]

200+ fieldNames = [nsroot n | (n, _, _, _, _) <- fields]

193

201

194 paramNames :: [Name]

202 paramNames :: [Name]

195− paramNames = [nsroot n | (n, _, _, _) <- params]

203+ paramNames = [nsroot n | (n, _, _, _, _) <- params]

196

204

197 isFieldOrParam :: Name -> Bool

205 isFieldOrParam :: Name -> Bool

198 isFieldOrParam n = n `elem` (fieldNames ++ paramNames)

206 isFieldOrParam n = n `elem` (fieldNames ++ paramNames)

@@ -207,7 +215,7 @@ elabRecordFunctions info rsyn fc tyn params fields dconName target

207 isField' (n, _, _, _, _, _) = isField n

215 isField' (n, _, _, _, _, _) = isField n

208

216

209 fieldTerms :: [PTerm]

217 fieldTerms :: [PTerm]

210− fieldTerms = [t | (_, _, t, _) <- fields]

218+ fieldTerms = [t | (_, _, _, t, _) <- fields]

211

219

212 -- Delabs the TT to PTerm

220 -- Delabs the TT to PTerm

213 -- This is not good.

221 -- This is not good.

@@ -238,7 +246,7 @@ elabRecordFunctions info rsyn fc tyn params fields dconName target

238 paramName (UN n) = sUN ("param_" ++ str n)

246 paramName (UN n) = sUN ("param_" ++ str n)

239 paramName (MN i n) = sMN i ("param_" ++ str n)

247 paramName (MN i n) = sMN i ("param_" ++ str n)

240 paramName (NS n s) = NS (paramName n) s

248 paramName (NS n s) = NS (paramName n) s

241− paramName n = n

249+ paramName n = n

242

250

243 -- | Elaborate the projection functions.

251 -- | Elaborate the projection functions.

244 elabProj :: Name -> [(Name, Name, Plicity, PTerm, Docstring (Either Err PTerm), Int)] -> Idris ()

252 elabProj :: Name -> [(Name, Name, Plicity, PTerm, Docstring (Either Err PTerm), Int)] -> Idris ()

@@ -263,15 +271,15 @@ elabRecordFunctions info rsyn fc tyn params fields dconName target

263

271

264 -- | A map from a field name to the other fields it depends on.

272 -- | A map from a field name to the other fields it depends on.

265 fieldDependencies :: [(Name, [Name])]

273 fieldDependencies :: [(Name, [Name])]

266− fieldDependencies = map (uncurry fieldDep) [(n, t) | (n, _, t, _) <- fields ++ params]

274+ fieldDependencies = map (uncurry fieldDep) [(n, t) | (n, _, _, t, _) <- fields ++ params]

267− where

275+ where

268 fieldDep :: Name -> PTerm -> (Name, [Name])

276 fieldDep :: Name -> PTerm -> (Name, [Name])

269 fieldDep n t = ((nsroot n), paramNames ++ fieldNames `intersect` allNamesIn t)

277 fieldDep n t = ((nsroot n), paramNames ++ fieldNames `intersect` allNamesIn t)

270

278

271 -- | A list of fields depending on another field.

279 -- | A list of fields depending on another field.

272 dependentFields :: [Name]

280 dependentFields :: [Name]

273 dependentFields = filter depends fieldNames

281 dependentFields = filter depends fieldNames

274− where

282+ where

275 depends :: Name -> Bool

283 depends :: Name -> Bool

276 depends n = case lookup n fieldDependencies of

284 depends n = case lookup n fieldDependencies of

277 Just xs -> not $ null xs

285 Just xs -> not $ null xs

@@ -313,7 +321,8 @@ elabProjection info cname pname plicity projTy pdoc psyn fc targetTy cn phArgs f

313 where

321 where

314 -- | The type of the projection function.

322 -- | The type of the projection function.

315 generateTy :: PDecl

323 generateTy :: PDecl

316− generateTy = PTy pdoc [] psyn fc [] pname $ PPi expl recName targetTy projTy

324+ generateTy = PTy pdoc [] psyn fc [] pname NoFC $

325+ PPi expl recName NoFC targetTy projTy

317

326

318 -- | The left hand side of the projection function.

327 -- | The left hand side of the projection function.

319 generateLhs :: PTerm

328 generateLhs :: PTerm

@@ -373,9 +382,11 @@ elabUpdate info cname pname plicity pty pdoc psyn fc sty cn args fnames i option

373 then logLvl 1 $ "Could not generate update function for " ++ show pname

382 then logLvl 1 $ "Could not generate update function for " ++ show pname

374 else tclift $ tfail $ At fc (Elaborating "record update function " pname err)) -}

383 else tclift $ tfail $ At fc (Elaborating "record update function " pname err)) -}

375 where

384 where

376− -- | The type of the udpate function.

385+ -- | The type of the update function.

377 generateTy :: PDecl

386 generateTy :: PDecl

378− generateTy = PTy pdoc [] psyn fc [] set_pname $ PPi expl (nsroot pname) pty (PPi expl recName sty (substInput sty))

387+ generateTy = PTy pdoc [] psyn fc [] set_pname NoFC $

388+ PPi expl (nsroot pname) NoFC pty $

389+ PPi expl recName NoFC sty (substInput sty)

379 where substInput = substMatches [(cname, PRef fc (nsroot pname))]

390 where substInput = substMatches [(cname, PRef fc (nsroot pname))]

380

391

381 -- | The "_set" name.

392 -- | The "_set" name.

src/Idris/Elab/Term.hs+106−45

@@ -48,6 +48,7 @@ data ElabResult =

48 -- ^ The potentially extended context from new definitions

49 , resultTyDecls :: [RDeclInstructions]

50 -- ^ Meta-info about the new type declarations

51+ , resultHighlighting :: [(FC, OutputAnnotation)]

51 }

52 }

@@ -110,13 +111,14 @@ build ist info emode opts fn tm

110 when tydecl (do mkPat

111 when tydecl (do mkPat

111 update_term liftPats

112 update_term liftPats

112 update_term orderPats)

113 update_term orderPats)

113− EState is _ impls <- getAux

114+ EState is _ impls highlights <- getAux

114 tt <- get_term

115 tt <- get_term

115 ctxt <- get_context

116 ctxt <- get_context

116 let (tm, ds) = runState (collectDeferred (Just fn) (map fst is) ctxt tt) []

117 let (tm, ds) = runState (collectDeferred (Just fn) (map fst is) ctxt tt) []

117 log <- getLog

118 log <- getLog

119+ if log /= ""

118− if (log /= "") then trace log $ return (ElabResult tm ds (map snd is) ctxt impls)

120+ then trace log $ return (ElabResult tm ds (map snd is) ctxt impls highlights)

119− else return (ElabResult tm ds (map snd is) ctxt impls)

121+ else return (ElabResult tm ds (map snd is) ctxt impls highlights)

120 where pattern = emode == ELHS

122 where pattern = emode == ELHS

121 tydecl = emode == ETyDecl

123 tydecl = emode == ETyDecl

122

124

@@ -152,13 +154,14 @@ buildTC ist info emode opts fn tm

152 -- unification

154 -- unification

153 when (not (null dots)) $

155 when (not (null dots)) $

154 lift (Error (CantMatch (getInferTerm tm)))

156 lift (Error (CantMatch (getInferTerm tm)))

155− EState is _ impls <- getAux

157+ EState is _ impls highlights <- getAux

156 tt <- get_term

158 tt <- get_term

157 ctxt <- get_context

159 ctxt <- get_context

158 let (tm, ds) = runState (collectDeferred (Just fn) (map fst is) ctxt tt) []

160 let (tm, ds) = runState (collectDeferred (Just fn) (map fst is) ctxt tt) []

159 log <- getLog

161 log <- getLog

162+ if (log /= "")

160− if (log /= "") then trace log $ return (ElabResult tm ds (map snd is) ctxt impls)

163+ then trace log $ return (ElabResult tm ds (map snd is) ctxt impls highlights)

161− else return (ElabResult tm ds (map snd is) ctxt impls)

164+ else return (ElabResult tm ds (map snd is) ctxt impls highlights)

162 where pattern = emode == ELHS

165 where pattern = emode == ELHS

163

166

164-- return whether arguments of the given constructor name can be

167-- return whether arguments of the given constructor name can be

@@ -318,18 +321,23 @@ elab ist info emode opts fn tm

318 -> PTerm -- ^ The term to elaborate

321 -> PTerm -- ^ The term to elaborate

319 -> ElabD ()

322 -> ElabD ()

320 elab' ina fc (PNoImplicits t) = elab' ina fc t -- skip elabE step

323 elab' ina fc (PNoImplicits t) = elab' ina fc t -- skip elabE step

321− elab' ina fc PType = do apply RType []; solve

324+ elab' ina fc (PType fc') =

325+ do apply RType []

326+ solve

327+ highlightSource fc' (AnnType "Type" "The type of types")

322 elab' ina fc (PUniverse u) = do apply (RUType u) []; solve

328 elab' ina fc (PUniverse u) = do apply (RUType u) []; solve

323-- elab' (_,_,inty) (PConstant c)

329-- elab' (_,_,inty) (PConstant c)

324-- | constType c && pattern && not reflection && not inty

330-- | constType c && pattern && not reflection && not inty

325-- = lift $ tfail (Msg "Typecase is not allowed")

331-- = lift $ tfail (Msg "Typecase is not allowed")

326− elab' ina fc tm@(PConstant c)

332+ elab' ina fc tm@(PConstant fc' c)

327 | pattern && not reflection && not (e_qq ina) && not (e_intype ina)

333 | pattern && not reflection && not (e_qq ina) && not (e_intype ina)

328 && isTypeConst c

334 && isTypeConst c

329 = lift $ tfail $ Msg ("No explicit types on left hand side: " ++ show tm)

335 = lift $ tfail $ Msg ("No explicit types on left hand side: " ++ show tm)

330 | pattern && not reflection && not (e_qq ina) && e_nomatching ina

336 | pattern && not reflection && not (e_qq ina) && e_nomatching ina

331 = lift $ tfail $ Msg ("Attempting concrete match on polymorphic argument: " ++ show tm)

337 = lift $ tfail $ Msg ("Attempting concrete match on polymorphic argument: " ++ show tm)

332− | otherwise = do apply (RConstant c) []; solve

338+ | otherwise = do apply (RConstant c) []

339+ solve

340+ highlightSource fc' (AnnConst c)

333 elab' ina fc (PQuote r) = do fill r; solve

341 elab' ina fc (PQuote r) = do fill r; solve

334 elab' ina _ (PTrue fc _) =

342 elab' ina _ (PTrue fc _) =

335 do hnf_compute

343 do hnf_compute

@@ -343,13 +351,16 @@ elab ist info emode opts fn tm

343 elab' ina fc (PResolveTC fc')

351 elab' ina fc (PResolveTC fc')

344 = do c <- getNameFrom (sMN 0 "class")

352 = do c <- getNameFrom (sMN 0 "class")

345 instanceArg c

353 instanceArg c

354+ -- Elaborate the equality type first homogeneously, then

355+ -- heterogeneously as a fallback

356+ elab' ina _ (PApp fc (PRef _ n) args)

346− elab' ina _ (PApp fc (PRef _ n) args) | n == eqTy, [Placeholder, Placeholder, l, r] <- map getTm args

357+ | n == eqTy, [Placeholder, Placeholder, l, r] <- map getTm args

347 = try (do tyn <- getNameFrom (sMN 0 "aqty")

358 = try (do tyn <- getNameFrom (sMN 0 "aqty")

348 claim tyn RType

359 claim tyn RType

349 movelast tyn

360 movelast tyn

350 elab' ina (Just fc) (PApp fc (PRef fc eqTy)

361 elab' ina (Just fc) (PApp fc (PRef fc eqTy)

351− [pimp (sUN "A") (PRef fc tyn) True,

362+ [pimp (sUN "A") (PRef NoFC tyn) True,

352− pimp (sUN "B") (PRef fc tyn) False,

363+ pimp (sUN "B") (PRef NoFC tyn) False,

353 pexp l, pexp r]))

364 pexp l, pexp r]))

354 (do atyn <- getNameFrom (sMN 0 "aqty")

365 (do atyn <- getNameFrom (sMN 0 "aqty")

355 btyn <- getNameFrom (sMN 0 "bqty")

366 btyn <- getNameFrom (sMN 0 "bqty")

@@ -358,8 +369,8 @@ elab ist info emode opts fn tm

358 claim btyn RType

369 claim btyn RType

359 movelast btyn

370 movelast btyn

360 elab' ina (Just fc) (PApp fc (PRef fc eqTy)

371 elab' ina (Just fc) (PApp fc (PRef fc eqTy)

361− [pimp (sUN "A") (PRef fc atyn) True,

372+ [pimp (sUN "A") (PRef NoFC atyn) True,

362− pimp (sUN "B") (PRef fc btyn) False,

373+ pimp (sUN "B") (PRef NoFC btyn) False,

363 pexp l, pexp r]))

374 pexp l, pexp r]))

364

375

365 elab' ina _ (PPair fc _ l r)

376 elab' ina _ (PPair fc _ l r)

@@ -402,7 +413,11 @@ elab ist info emode opts fn tm

402 _ -> asType

413 _ -> asType

403 where asType = elab' ina (Just fc) (PApp fc (PRef fc sigmaTy)

414 where asType = elab' ina (Just fc) (PApp fc (PRef fc sigmaTy)

404 [pexp t,

415 [pexp t,

416+

417+ -- TODO: save the FC from the dependent pair

418+ -- syntax and put it on this lambda for interactive

419+ -- semantic highlighting support. NoFC for now.

405− pexp (PLam fc n Placeholder r)])

420+ pexp (PLam fc n NoFC Placeholder r)])

406 asValue = elab' ina (Just fc) (PApp fc (PRef fc sigmaCon)

421 asValue = elab' ina (Just fc) (PApp fc (PRef fc sigmaCon)

407 [pimp (sMN 0 "a") t False,

422 [pimp (sMN 0 "a") t False,

408 pimp (sMN 0 "P") Placeholder True,

423 pimp (sMN 0 "P") Placeholder True,

@@ -411,7 +426,7 @@ elab ist info emode opts fn tm

411 [pimp (sMN 0 "a") t False,

426 [pimp (sMN 0 "a") t False,

412 pimp (sMN 0 "P") Placeholder True,

427 pimp (sMN 0 "P") Placeholder True,

413 pexp l, pexp r])

428 pexp l, pexp r])

414− elab' ina fc (PAlternative True as)

429+ elab' ina fc (PAlternative True as)

415 = do hnf_compute

430 = do hnf_compute

416 ty <- goal

431 ty <- goal

417 ctxt <- get_context

432 ctxt <- get_context

@@ -436,7 +451,10 @@ elab ist info emode opts fn tm

436 trySeq' deferr (x : xs)

451 trySeq' deferr (x : xs)

437 = try' (do elab' ina fc x

452 = try' (do elab' ina fc x

438 solveAutos ist fn False) (trySeq' deferr xs) True

453 solveAutos ist fn False) (trySeq' deferr xs) True

439− elab' ina _ (PPatvar fc n) | bindfree = do patvar n; update_term liftPats

454+ elab' ina _ (PPatvar fc n) | bindfree

455+ = do patvar n

456+ update_term liftPats

457+ highlightSource fc (AnnBoundName n False)

440-- elab' (_, _, inty) (PRef fc f)

458-- elab' (_, _, inty) (PRef fc f)

441-- | isTConName f (tt_ctxt ist) && pattern && not reflection && not inty

459-- | isTConName f (tt_ctxt ist) && pattern && not reflection && not inty

442-- = lift $ tfail (Msg "Typecase is not allowed")

460-- = lift $ tfail (Msg "Typecase is not allowed")

@@ -451,39 +469,56 @@ elab ist info emode opts fn tm

451 guarded = e_guarded ec

469 guarded = e_guarded ec

452 inty = e_intype ec

470 inty = e_intype ec

453 ctxt <- get_context

471 ctxt <- get_context

472+

454 let defined = case lookupTy n ctxt of

473 let defined = case lookupTy n ctxt of

455 [] -> False

474 [] -> False

456 _ -> True

475 _ -> True

457 -- this is to stop us resolve type classes recursively

476 -- this is to stop us resolve type classes recursively

458 -- trace (show (n, guarded)) $

477 -- trace (show (n, guarded)) $

478+ if (tcname n && ina)

479+ then erun fc $

480+ do patvar n

459− if (tcname n && ina) then erun fc $ do patvar n; update_term liftPats

481+ update_term liftPats

482+ highlightSource fc (AnnBoundName n False)

460 else if (defined && not guarded)

483 else if (defined && not guarded)

461− then do apply (Var n) []; solve

484+ then do apply (Var n) []

485+ annot <- findHighlight n

486+ solve

487+ highlightSource fc annot

462− else try (do apply (Var n) []; solve)

488+ else try (do apply (Var n) []

489+ annot <- findHighlight n

490+ solve

491+ highlightSource fc annot)

492+ (do patvar n

463− (do patvar n; update_term liftPats)

493+ update_term liftPats

494+ highlightSource fc (AnnBoundName n False))

464 where inparamBlock n = case lookupCtxtName n (inblock info) of

495 where inparamBlock n = case lookupCtxtName n (inblock info) of

465 [] -> False

496 [] -> False

466 _ -> True

497 _ -> True

467 bindable (NS _ _) = False

498 bindable (NS _ _) = False

468 bindable (UN xs) = True

499 bindable (UN xs) = True

469 bindable n = implicitable n

500 bindable n = implicitable n

470− elab' ina _ f@(PInferRef fc n) = elab' ina (Just fc) (PApp fc f [])

501+ elab' ina _ f@(PInferRef fc n) = elab' ina (Just fc) (PApp NoFC f [])

471 elab' ina fc' tm@(PRef fc n)

502 elab' ina fc' tm@(PRef fc n)

472 | pattern && not reflection && not (e_qq ina) && not (e_intype ina)

503 | pattern && not reflection && not (e_qq ina) && not (e_intype ina)

473 && isTConName n (tt_ctxt ist)

504 && isTConName n (tt_ctxt ist)

474 = lift $ tfail $ Msg ("No explicit types on left hand side: " ++ show tm)

505 = lift $ tfail $ Msg ("No explicit types on left hand side: " ++ show tm)

475 | pattern && not reflection && not (e_qq ina) && e_nomatching ina

506 | pattern && not reflection && not (e_qq ina) && e_nomatching ina

476 = lift $ tfail $ Msg ("Attempting concrete match on polymorphic argument: " ++ show tm)

507 = lift $ tfail $ Msg ("Attempting concrete match on polymorphic argument: " ++ show tm)

477− | otherwise =

508+ | otherwise =

478 do fty <- get_type (Var n) -- check for implicits

509 do fty <- get_type (Var n) -- check for implicits

479 ctxt <- get_context

510 ctxt <- get_context

480− env <- get_env

511+ env <- get_env

481 let a' = insertScopedImps fc (normalise ctxt env fty) []

512 let a' = insertScopedImps fc (normalise ctxt env fty) []

482 if null a'

513 if null a'

514+ then erun fc $

483− then erun fc $ do apply (Var n) []; solve

515+ do apply (Var n) []

516+ hl <- findHighlight n

517+ solve

518+ highlightSource fc hl

484 else elab' ina fc' (PApp fc tm [])

519 else elab' ina fc' (PApp fc tm [])

485− elab' ina _ (PLam _ _ _ PImpossible) = lift . tfail . Msg $ "Only pattern-matching lambdas can be impossible"

520+ elab' ina _ (PLam _ _ _ _ PImpossible) = lift . tfail . Msg $ "Only pattern-matching lambdas can be impossible"

486− elab' ina _ (PLam fc n Placeholder sc)

521+ elab' ina _ (PLam fc n nfc Placeholder sc)

487 = do -- if n is a type constructor name, this makes no sense...

522 = do -- if n is a type constructor name, this makes no sense...

488 ctxt <- get_context

523 ctxt <- get_context

489 when (isTConName n ctxt) $

524 when (isTConName n ctxt) $

@@ -492,7 +527,8 @@ elab ist info emode opts fn tm

492 attack; intro (Just n);

527 attack; intro (Just n);

493 -- trace ("------ intro " ++ show n ++ " ---- \n" ++ show ptm)

528 -- trace ("------ intro " ++ show n ++ " ---- \n" ++ show ptm)

494 elabE (ina { e_inarg = True } ) (Just fc) sc; solve

529 elabE (ina { e_inarg = True } ) (Just fc) sc; solve

530+ highlightSource nfc (AnnBoundName n False)

495− elab' ec _ (PLam fc n ty sc)

531+ elab' ec _ (PLam fc n nfc ty sc)

496 = do tyn <- getNameFrom (sMN 0 "lamty")

532 = do tyn <- getNameFrom (sMN 0 "lamty")

497 -- if n is a type constructor name, this makes no sense...

533 -- if n is a type constructor name, this makes no sense...

498 ctxt <- get_context

534 ctxt <- get_context

@@ -510,11 +546,13 @@ elab ist info emode opts fn tm

510 elabE (ec { e_inarg = True, e_intype = True }) (Just fc) ty

546 elabE (ec { e_inarg = True, e_intype = True }) (Just fc) ty

511 elabE (ec { e_inarg = True }) (Just fc) sc

547 elabE (ec { e_inarg = True }) (Just fc) sc

512 solve

548 solve

549+ highlightSource nfc (AnnBoundName n False)

513− elab' ina fc (PPi p n Placeholder sc)

550+ elab' ina fc (PPi p n nfc Placeholder sc)

514− = do attack; arg n (is_scoped p) (sMN 0 "ty")

551+ = do attack; arg n (is_scoped p) (sMN 0 "ty")

515 elabE (ina { e_inarg = True, e_intype = True }) fc sc

552 elabE (ina { e_inarg = True, e_intype = True }) fc sc

516 solve

553 solve

554+ highlightSource nfc (AnnBoundName n False)

517− elab' ina fc (PPi p n ty sc)

555+ elab' ina fc (PPi p n nfc ty sc)

518 = do attack; tyn <- getNameFrom (sMN 0 "ty")

556 = do attack; tyn <- getNameFrom (sMN 0 "ty")

519 claim tyn RType

557 claim tyn RType

520 n' <- case n of

558 n' <- case n of

@@ -526,7 +564,8 @@ elab ist info emode opts fn tm

526 elabE ec' fc ty

564 elabE ec' fc ty

527 elabE ec' fc sc

565 elabE ec' fc sc

528 solve

566 solve

567+ highlightSource nfc (AnnBoundName n False)

529− elab' ina _ (PLet fc n ty val sc)

568+ elab' ina _ (PLet fc n nfc ty val sc)

530 = do attack

569 = do attack

531 ivs <- get_instances

570 ivs <- get_instances

532 tyn <- getNameFrom (sMN 0 "letty")

571 tyn <- getNameFrom (sMN 0 "letty")

@@ -562,6 +601,7 @@ elab ist info emode opts fn tm

562 Just (Let t v) -> v

601 Just (Let t v) -> v

563 other -> error ("Value not a let binding: " ++ show other))

602 other -> error ("Value not a let binding: " ++ show other))

564 solve

603 solve

604+ highlightSource nfc (AnnBoundName n False)

565 elab' ina _ (PGoal fc r n sc) = do

605 elab' ina _ (PGoal fc r n sc) = do

566 rty <- goal

606 rty <- goal

567 attack

607 attack

@@ -633,7 +673,7 @@ elab ist info emode opts fn tm

633 solve

673 solve

634 -- if f is local, just do a simple_app

674 -- if f is local, just do a simple_app

635 -- FIXME: Anyone feel like refactoring this mess? - EB

675 -- FIXME: Anyone feel like refactoring this mess? - EB

636− elab' ina topfc tm@(PApp fc (PRef _ f) args_in)

676+ elab' ina topfc tm@(PApp fc (PRef ffc f) args_in)

637 | pattern && not reflection && not (e_qq ina) && e_nomatching ina

677 | pattern && not reflection && not (e_qq ina) && e_nomatching ina

638 = lift $ tfail $ Msg ("Attempting concrete match on polymorphic argument: " ++ show tm)

678 = lift $ tfail $ Msg ("Attempting concrete match on polymorphic argument: " ++ show tm)

639 | otherwise = implicitApp $

679 | otherwise = implicitApp $

@@ -641,6 +681,7 @@ elab ist info emode opts fn tm

641 ty <- goal

681 ty <- goal

642 fty <- get_type (Var f)

682 fty <- get_type (Var f)

643 ctxt <- get_context

683 ctxt <- get_context

684+ annot <- findHighlight f

644 let args = insertScopedImps fc (normalise ctxt env fty) args_in

685 let args = insertScopedImps fc (normalise ctxt env fty) args_in

645 let unmatchableArgs = if pattern

686 let unmatchableArgs = if pattern

646 then getUnmatchable (tt_ctxt ist) f

687 then getUnmatchable (tt_ctxt ist) f

@@ -651,11 +692,12 @@ elab ist info emode opts fn tm

651 lift $ tfail $ Msg ("No explicit types on left hand side: " ++ show tm)

692 lift $ tfail $ Msg ("No explicit types on left hand side: " ++ show tm)

652 if (f `elem` map fst env && length args == 1 && length args_in == 1)

693 if (f `elem` map fst env && length args == 1 && length args_in == 1)

653 then -- simple app, as below

694 then -- simple app, as below

654− do simple_app False

695+ do simple_app False

655− (elabE (ina { e_isfn = True }) (Just fc) (PRef fc f))

696+ (elabE (ina { e_isfn = True }) (Just fc) (PRef ffc f))

656 (elabE (ina { e_inarg = True }) (Just fc) (getTm (head args)))

697 (elabE (ina { e_inarg = True }) (Just fc) (getTm (head args)))

657 (show tm)

698 (show tm)

658 solve

699 solve

700+ highlightSource ffc annot

659 return []

701 return []

660 else

702 else

661 do ivs <- get_instances

703 do ivs <- get_instances

@@ -682,8 +724,12 @@ elab ist info emode opts fn tm

682 let (ns', eargs) = unzip $

724 let (ns', eargs) = unzip $

683 sortBy cmpArg (zip ns args)

725 sortBy cmpArg (zip ns args)

684 ulog <- getUnifyLog

726 ulog <- getUnifyLog

727+

728+ annot <- findHighlight f

729+ highlightSource ffc annot

730+

685 elabArgs ist (ina { e_inarg = e_inarg ina || not isinf })

731 elabArgs ist (ina { e_inarg = e_inarg ina || not isinf })

686− [] fc False f

732+ [] fc False f

687 (zip ns' (unmatchableArgs ++ repeat False))

733 (zip ns' (unmatchableArgs ++ repeat False))

688 (f == sUN "Force")

734 (f == sUN "Force")

689 (map (\x -> getTm x) eargs) -- TODO: remove this False arg

735 (map (\x -> getTm x) eargs) -- TODO: remove this False arg

@@ -755,7 +801,7 @@ elab ist info emode opts fn tm

755 PAlternative False _ -> 5

801 PAlternative False _ -> 5

756 PAlternative True _ -> 2

802 PAlternative True _ -> 2

757 PTactics _ -> 150

803 PTactics _ -> 150

758− PLam _ _ _ _ -> 3

804+ PLam _ _ _ _ _ -> 3

759 PRewrite _ _ _ _ -> 4

805 PRewrite _ _ _ _ -> 4

760 PResolveTC _ -> 0

806 PResolveTC _ -> 0

761 PHidden _ -> 150

807 PHidden _ -> 150

@@ -815,10 +861,10 @@ elab ist info emode opts fn tm

815 setInjective (PApp _ (PRef _ n) _) = setinj n

861 setInjective (PApp _ (PRef _ n) _) = setinj n

816 setInjective _ = return ()

862 setInjective _ = return ()

817

863

818− elab' ina _ tm@(PApp fc f [arg]) =

864+ elab' ina _ tm@(PApp fc f [arg]) =

819 erun fc $

865 erun fc $

820 do simple_app (not $ headRef f)

866 do simple_app (not $ headRef f)

821− (elabE (ina { e_isfn = True }) (Just fc) f)

867+ (elabE (ina { e_isfn = True }) (Just fc) f)

822 (elabE (ina { e_inarg = True }) (Just fc) (getTm arg))

868 (elabE (ina { e_inarg = True }) (Just fc) (getTm arg))

823 (show tm)

869 (show tm)

824 solve

870 solve

@@ -1035,9 +1081,12 @@ elab ist info emode opts fn tm

1035 end_unify

1081 end_unify

1036

1082

1037 -- We now have an elaborated term. Reflect it and solve the

1083 -- We now have an elaborated term. Reflect it and solve the

1038− -- original goal in the original proof state.

1084+ -- original goal in the original proof state, preserving highlighting

1039 env <- get_env

1085 env <- get_env

1086+ EState _ _ _ hs <- getAux

1040 loadState

1087 loadState

1088+ updateAux (\aux -> aux { highlighting = hs })

1089+

1041 let quoted = fmap (explicitNames . binderVal) $ lookup nTm env

1090 let quoted = fmap (explicitNames . binderVal) $ lookup nTm env

1042 isRaw = case unApply (normaliseAll ctxt env finalTy) of

1091 isRaw = case unApply (normaliseAll ctxt env finalTy) of

1043 (P _ n _, []) | n == reflm "Raw" -> True

1092 (P _ n _, []) | n == reflm "Raw" -> True

@@ -1216,9 +1265,9 @@ elab ist info emode opts fn tm

1216 do impn <- unique_hole (sMN 0 "imp")

1265 do impn <- unique_hole (sMN 0 "imp")

1217 if e_isfn ina -- apply to an implicit immediately

1266 if e_isfn ina -- apply to an implicit immediately

1218 then return (PApp emptyFC

1267 then return (PApp emptyFC

1219− (PLam emptyFC impn Placeholder t)

1268+ (PLam emptyFC impn NoFC Placeholder t)

1220 [pexp Placeholder])

1269 [pexp Placeholder])

1221− else return (PLam emptyFC impn Placeholder t)

1270+ else return (PLam emptyFC impn NoFC Placeholder t)

1222 addLam _ t = return t

1271 addLam _ t = return t

1223

1272

1224 insertCoerce ina t@(PCase _ _ _) = return t

1273 insertCoerce ina t@(PCase _ _ _) = return t

@@ -1255,7 +1304,7 @@ elab ist info emode opts fn tm

1255 elabArgs ist ina failed fc retry f [] force _ = return ()

1304 elabArgs ist ina failed fc retry f [] force _ = return ()

1256 elabArgs ist ina failed fc r f (((argName, holeName), unm):ns) force (t : args)

1305 elabArgs ist ina failed fc r f (((argName, holeName), unm):ns) force (t : args)

1257 = do hs <- get_holes

1306 = do hs <- get_holes

1258− if holeName `elem` hs then

1307+ if holeName `elem` hs then

1259 do focus holeName

1308 do focus holeName

1260 case t of

1309 case t of

1261 Placeholder -> do movelast holeName

1310 Placeholder -> do movelast holeName

@@ -1352,7 +1401,7 @@ pruneByType env (P _ n _) ctxt as

1352 where

1401 where

1353 headIs var f (PApp _ (PRef _ f') _) = typeHead var f f'

1402 headIs var f (PApp _ (PRef _ f') _) = typeHead var f f'

1354 headIs var f (PApp _ f' _) = headIs var f f'

1403 headIs var f (PApp _ f' _) = headIs var f f'

1355− headIs var f (PPi _ _ _ sc) = headIs var f sc

1404+ headIs var f (PPi _ _ _ _ sc) = headIs var f sc

1356 headIs var f (PHidden t) = headIs var f t

1405 headIs var f (PHidden t) = headIs var f t

1357 headIs _ _ _ = True -- keep if it's not an application

1406 headIs _ _ _ = True -- keep if it's not an application

1358

1407

@@ -1370,6 +1419,18 @@ pruneByType env (P _ n _) ctxt as

1370

1419

1371pruneByType _ t _ as = as

1420pruneByType _ t _ as = as

1372

1421

1422+-- | Use the local elab context to work out the highlighting for a name

1423+findHighlight :: Name -> ElabD OutputAnnotation

1424+findHighlight n = do ctxt <- get_context

1425+ env <- get_env

1426+ case lookup n env of

1427+ Just _ -> return $ AnnBoundName n False

1428+ Nothing -> case lookupTyExact n ctxt of

1429+ Just _ -> return $ AnnName n Nothing Nothing Nothing

1430+ Nothing -> lift . tfail . InternalMsg $

1431+ "Can't find name" ++ show n

1432+

1433+

1373findInstances :: IState -> Term -> [Name]

1434findInstances :: IState -> Term -> [Name]

1374findInstances ist t

1435findInstances ist t

1375 | (P _ n _, _) <- unApply (getRetTy t)

1436 | (P _ n _, _) <- unApply (getRetTy t)

@@ -2265,7 +2326,7 @@ processTacticDecls info steps =

2265 let tcgen = False -- TODO: later we may support dictionary generation

2326 let tcgen = False -- TODO: later we may support dictionary generation

2266 case elaborate ctxt (idris_datatypes ist) (sMN 0 "refPatLHS") infP initEState

2327 case elaborate ctxt (idris_datatypes ist) (sMN 0 "refPatLHS") infP initEState

2267 (erun fc (buildTC ist info ELHS [] fname (infTerm lhs))) of

2328 (erun fc (buildTC ist info ELHS [] fname (infTerm lhs))) of

2268− OK (ElabResult lhs' _ _ _ _, _) ->

2329+ OK (ElabResult lhs' _ _ _ _ _, _) ->

2269 do -- not recursively calling here, because we don't

2330 do -- not recursively calling here, because we don't

2270 -- want to run infinitely many times

2331 -- want to run infinitely many times

2271 let lhs_tm = orderPats (getInferTerm lhs')

2332 let lhs_tm = orderPats (getInferTerm lhs')

src/Idris/Elab/Transform.hs+5−3

@@ -14,7 +14,7 @@ import Idris.Primitives

14import Idris.Inliner

15import Idris.PartialEval

16import Idris.DeepSeq

17−import Idris.Output (iputStrLn, pshow, iWarn)

17+import Idris.Output (iputStrLn, pshow, iWarn, sendHighlighting)

18import IRTS.Lang

20import Idris.Elab.Utils

@@ -53,12 +53,13 @@ elabTransform info fc safe lhs_in@(PApp _ (PRef _ tf) _) rhs_in

53 = do ctxt <- getContext

54 i <- getIState

55 let lhs = addImplPat i lhs_in

56− (ElabResult lhs' dlhs [] ctxt' newDecls, _) <-

56+ (ElabResult lhs' dlhs [] ctxt' newDecls highlights, _) <-

57 tclift $ elaborate ctxt (idris_datatypes i) (sMN 0 "transLHS") infP initEState

58 (erun fc (buildTC i info ELHS [] (sUN "transform")

59 (infTerm lhs)))

60 setContext ctxt'

61 processTacticDecls info newDecls

62+ sendHighlighting highlights

62 let lhs_tm = orderPats (getInferTerm lhs')

63 let lhs_tm = orderPats (getInferTerm lhs')

63 let lhs_ty = getInferType lhs'

64 let lhs_ty = getInferType lhs'

64 let newargs = pvars i lhs_tm

65 let newargs = pvars i lhs_tm

@@ -72,13 +73,14 @@ elabTransform info fc safe lhs_in@(PApp _ (PRef _ tf) _) rhs_in

72 tclift $ elaborate ctxt (idris_datatypes i) (sMN 0 "transRHS") clhs_ty initEState

73 tclift $ elaborate ctxt (idris_datatypes i) (sMN 0 "transRHS") clhs_ty initEState

73 (do pbinds i lhs_tm

74 (do pbinds i lhs_tm

74 setNextName

75 setNextName

75− (ElabResult _ _ _ ctxt' newDecls) <- erun fc (build i info ERHS [] (sUN "transform") rhs)

76+ (ElabResult _ _ _ ctxt' newDecls highlights) <- erun fc (build i info ERHS [] (sUN "transform") rhs)

76 erun fc $ psolve lhs_tm

77 erun fc $ psolve lhs_tm

77 tt <- get_term

78 tt <- get_term

78 let (rhs', defer) = runState (collectDeferred Nothing [] ctxt tt) []

79 let (rhs', defer) = runState (collectDeferred Nothing [] ctxt tt) []

79 return (rhs', defer, ctxt', newDecls))

80 return (rhs', defer, ctxt', newDecls))

80 setContext ctxt'

81 setContext ctxt'

81 processTacticDecls info newDecls

82 processTacticDecls info newDecls

83+ sendHighlighting highlights

83 (crhs_tm_in, crhs_ty) <- recheckC fc id [] rhs'

85 (crhs_tm_in, crhs_ty) <- recheckC fc id [] rhs'

84 let crhs_tm = renamepats pnames crhs_tm_in

86 let crhs_tm = renamepats pnames crhs_tm_in

src/Idris/Elab/Type.hs+14−9

@@ -16,7 +16,7 @@ import Idris.Primitives

16import Idris.Inliner

17import Idris.PartialEval

18import Idris.DeepSeq

19−import Idris.Output (iputStrLn, pshow, iWarn)

19+import Idris.Output (iputStrLn, pshow, iWarn, sendHighlighting)

20import IRTS.Lang

22import Idris.Elab.Utils

@@ -66,11 +66,12 @@ buildType info syn fc opts n ty' = do

66 logLvl 5 $ show n ++ " type pre-addimpl " ++ showTmImpls ty'

67 logLvl 2 $ show n ++ " type " ++ show (using syn) ++ "\n" ++ showTmImpls ty

69− (ElabResult tyT' defer is ctxt' newDecls, log) <-

69+ (ElabResult tyT' defer is ctxt' newDecls highlights, log) <-

70 tclift $ elaborate ctxt (idris_datatypes i) n (TType (UVal 0)) initEState

71 (errAt "type of " n (erun fc (build i info ETyDecl [] n ty)))

72 setContext ctxt'

73 processTacticDecls info newDecls

74+ sendHighlighting highlights

75 let tyT = patToImp tyT'

76 let tyT = patToImp tyT'

@@ -120,14 +121,16 @@ buildType info syn fc opts n ty' = do

120-- | Elaborate a top-level type declaration - for example, "foo : Int -> Int".

121-- | Elaborate a top-level type declaration - for example, "foo : Int -> Int".

121elabType :: ElabInfo -> SyntaxInfo

122elabType :: ElabInfo -> SyntaxInfo

122 -> Docstring (Either Err PTerm) -> [(Name, Docstring (Either Err PTerm))]

123 -> Docstring (Either Err PTerm) -> [(Name, Docstring (Either Err PTerm))]

124+ -> FC -> FnOpts

125+ -> Name -> FC -- ^ The precise location of the name

123− -> FC -> FnOpts -> Name -> PTerm -> Idris Type

126+ -> PTerm -> Idris Type

124elabType = elabType' False

127elabType = elabType' False

125

128

126elabType' :: Bool -> -- normalise it

129elabType' :: Bool -> -- normalise it

127 ElabInfo -> SyntaxInfo ->

130 ElabInfo -> SyntaxInfo ->

128 Docstring (Either Err PTerm) -> [(Name, Docstring (Either Err PTerm))] ->

131 Docstring (Either Err PTerm) -> [(Name, Docstring (Either Err PTerm))] ->

129− FC -> FnOpts -> Name -> PTerm -> Idris Type

132+ FC -> FnOpts -> Name -> FC -> PTerm -> Idris Type

130−elabType' norm info syn doc argDocs fc opts n ty' = {- let ty' = piBind (params info) ty_in

133+elabType' norm info syn doc argDocs fc opts n nfc ty' = {- let ty' = piBind (params info) ty_in

131 n = liftname info n_in in -}

134 n = liftname info n_in in -}

132 do checkUndefined fc n

135 do checkUndefined fc n

133 (cty, _, ty, inacc) <- buildType info syn fc opts n ty'

136 (cty, _, ty, inacc) <- buildType info syn fc opts n ty'

@@ -192,6 +195,8 @@ elabType' norm info syn doc argDocs fc opts n ty' = {- let ty' = piBind (params

192 addIBC (IBCErrorHandler n)

195 addIBC (IBCErrorHandler n)

193 else ifail $ "The type " ++ show nty' ++ " is invalid for an error handler"

196 else ifail $ "The type " ++ show nty' ++ " is invalid for an error handler"

194 else ifail "Error handlers can only be defined when the ErrorReflection language extension is enabled."

197 else ifail "Error handlers can only be defined when the ErrorReflection language extension is enabled."

198+ -- Send highlighting information about the name being declared

199+ sendHighlighting [(nfc, AnnName n Nothing Nothing Nothing)]

195 -- if it's an export list type, make a note of it

200 -- if it's an export list type, make a note of it

196 case (unApply usety) of

201 case (unApply usety) of

197 (P _ ut _, _)

202 (P _ ut _, _)

@@ -203,8 +208,8 @@ elabType' norm info syn doc argDocs fc opts n ty' = {- let ty' = piBind (params

203 -- for making an internalapp, we only want the explicit ones, and don't

208 -- for making an internalapp, we only want the explicit ones, and don't

204 -- want the parameters, so just take the arguments which correspond to the

209 -- want the parameters, so just take the arguments which correspond to the

205 -- user declared explicit ones

210 -- user declared explicit ones

206− mergeTy (PPi e n ty sc) (PPi e' n' _ sc')

211+ mergeTy (PPi e n fc ty sc) (PPi e' n' _ _ sc')

207− | e == e' = PPi e n ty (mergeTy sc sc')

212+ | e == e' = PPi e n fc ty (mergeTy sc sc')

208 | otherwise = mergeTy sc sc'

213 | otherwise = mergeTy sc sc'

209 mergeTy _ sc = sc

214 mergeTy _ sc = sc

210

215

@@ -229,7 +234,7 @@ elabType' norm info syn doc argDocs fc opts n ty' = {- let ty' = piBind (params

229elabPostulate :: ElabInfo -> SyntaxInfo -> Docstring (Either Err PTerm) ->

234elabPostulate :: ElabInfo -> SyntaxInfo -> Docstring (Either Err PTerm) ->

230 FC -> FnOpts -> Name -> PTerm -> Idris ()

235 FC -> FnOpts -> Name -> PTerm -> Idris ()

231elabPostulate info syn doc fc opts n ty = do

236elabPostulate info syn doc fc opts n ty = do

232− elabType info syn doc [] fc opts n ty

237+ elabType info syn doc [] fc opts n NoFC ty

233 putIState . (\ist -> ist{ idris_postulates = S.insert n (idris_postulates ist) }) =<< getIState

238 putIState . (\ist -> ist{ idris_postulates = S.insert n (idris_postulates ist) }) =<< getIState

234 addIBC (IBCPostulate n)

239 addIBC (IBCPostulate n)

235

240

@@ -239,7 +244,7 @@ elabPostulate info syn doc fc opts n ty = do

239elabExtern :: ElabInfo -> SyntaxInfo -> Docstring (Either Err PTerm) ->

244elabExtern :: ElabInfo -> SyntaxInfo -> Docstring (Either Err PTerm) ->

240 FC -> FnOpts -> Name -> PTerm -> Idris ()

245 FC -> FnOpts -> Name -> PTerm -> Idris ()

241elabExtern info syn doc fc opts n ty = do

246elabExtern info syn doc fc opts n ty = do

242− cty <- elabType info syn doc [] fc opts n ty

247+ cty <- elabType info syn doc [] fc opts n NoFC ty

243 ist <- getIState

248 ist <- getIState

244 let arity = length (getArgTys (normalise (tt_ctxt ist) [] cty))

249 let arity = length (getArgTys (normalise (tt_ctxt ist) [] cty))

245

250

src/Idris/Elab/Utils.hs+9−9

@@ -66,9 +66,9 @@ inaccessibleImps _ _ _ = []

67-- | Get the list of (index, name) of inaccessible arguments from the type.

68inaccessibleArgs :: Int -> PTerm -> [(Int, Name)]

69−inaccessibleArgs i (PPi (Imp _ _ _ _) n Placeholder t)

69+inaccessibleArgs i (PPi (Imp _ _ _ _) n _ Placeholder t)

70 = (i,n) : inaccessibleArgs (i+1) t -- unbound implicit

71−inaccessibleArgs i (PPi plicity n ty t)

71+inaccessibleArgs i (PPi plicity n _ ty t)

72 | InaccessibleArg `elem` pargopts plicity

73 = (i,n) : inaccessibleArgs (i+1) t -- an .{erased : Implicit}

74 | otherwise

@@ -117,14 +117,14 @@ inferredDiff fc inf user =

117-- found, or it will give spurious errors.

118checkDocs :: FC -> [(Name, Docstring a)] -> PTerm -> Idris ()

119checkDocs fc args tm = cd (Map.fromList args) tm

120− where cd as (PPi _ n _ sc) = cd (Map.delete n as) sc

120+ where cd as (PPi _ n _ _ sc) = cd (Map.delete n as) sc

121 cd as _ | Map.null as = return ()

122 | otherwise = ierror . At fc . Msg $

123 "There is documentation for argument(s) "

124 ++ (concat . intersperse ", " . map show . Map.keys) as

125 ++ " but they were not found."

126

127−decorateid decorate (PTy doc argdocs s f o n t) = PTy doc argdocs s f o (decorate n) t

127+decorateid decorate (PTy doc argdocs s f o n nfc t) = PTy doc argdocs s f o (decorate n) nfc t

128decorateid decorate (PClauses f o n cs)

129 = PClauses f o (decorate n) (map dc cs)

130 where dc (PClause fc n t as w ds) = PClause fc (decorate n) (dappname t) as w ds

@@ -272,14 +272,14 @@ getStatics ns (Bind n (Pi _ _ _) t)

272getStatics _ _ = []

273

274mkStatic :: [Name] -> PDecl -> PDecl

275−mkStatic ns (PTy doc argdocs syn fc o n ty)

275+mkStatic ns (PTy doc argdocs syn fc o n nfc ty)

276− = PTy doc argdocs syn fc o n (mkStaticTy ns ty)

276+ = PTy doc argdocs syn fc o n nfc (mkStaticTy ns ty)

277mkStatic ns t = t

278

279mkStaticTy :: [Name] -> PTerm -> PTerm

280−mkStaticTy ns (PPi p n ty sc)

280+mkStaticTy ns (PPi p n fc ty sc)

281− | n `elem` ns = PPi (p { pstatic = Static }) n ty (mkStaticTy ns sc)

281+ | n `elem` ns = PPi (p { pstatic = Static }) n fc ty (mkStaticTy ns sc)

282− | otherwise = PPi p n ty (mkStaticTy ns sc)

282+ | otherwise = PPi p n fc ty (mkStaticTy ns sc)

283mkStaticTy ns t = t

284

285

src/Idris/Elab/Value.hs+7−6

@@ -15,7 +15,7 @@ import Idris.Primitives

15import Idris.Inliner

16import Idris.PartialEval

17import Idris.DeepSeq

18−import Idris.Output (iputStrLn, pshow, iWarn)

18+import Idris.Output (iputStrLn, pshow, iWarn, sendHighlighting)

19import IRTS.Lang

21import Idris.Elab.Utils

@@ -63,13 +63,14 @@ elabValBind info aspat norm tm_in

63 -- * elaboration as a Type

64 -- * elaboration as a function a -> b

66− (ElabResult tm' defer is ctxt' newDecls, _) <-

66+ (ElabResult tm' defer is ctxt' newDecls highlights, _) <-

67 tclift (elaborate ctxt (idris_datatypes i) (sMN 0 "val") infP initEState

68 (build i info aspat [Reflection] (sMN 0 "val") (infTerm tm)))

70 -- Extend the context with new definitions created

71 setContext ctxt'

72 processTacticDecls info newDecls

73+ sendHighlighting highlights

74 let vtm = orderPats (getInferTerm tm')

75 let vtm = orderPats (getInferTerm tm')

@@ -118,14 +119,14 @@ elabDocTerms info str = do typechecked <- Traversable.mapM decorate str

118-- Try running the term directly (as IO ()), then printing it as an Integer

119-- Try running the term directly (as IO ()), then printing it as an Integer

119-- (as a default numeric tye), then printing it as any Showable thing

120-- (as a default numeric tye), then printing it as any Showable thing

120elabExec :: FC -> PTerm -> PTerm

121elabExec :: FC -> PTerm -> PTerm

121−elabExec fc tm = runtm (PAlternative False

122+elabExec fc tm = runtm (PAlternative False

122 [printtm (PApp fc (PRef fc (sUN "the"))

123 [printtm (PApp fc (PRef fc (sUN "the"))

123− [pexp (PConstant (AType (ATInt ITBig))), pexp tm]),

124+ [pexp (PConstant NoFC (AType (ATInt ITBig))), pexp tm]),

124 tm,

125 tm,

125 printtm tm

126 printtm tm

126 ])

127 ])

127− where

128+ where

128 runtm t = PApp fc (PRef fc (sUN "run__IO")) [pexp t]

129 runtm t = PApp fc (PRef fc (sUN "run__IO")) [pexp t]

129− printtm t = PApp fc (PRef fc (sUN "printLn"))

130+ printtm t = PApp fc (PRef fc (sUN "printLn"))

130 [pimp (sUN "ffi") (PRef fc (sUN "FFI_C")) False, pexp t]

131 [pimp (sUN "ffi") (PRef fc (sUN "FFI_C")) False, pexp t]

131

132

src/Idris/ElabDecls.hs+9−9

@@ -156,10 +156,10 @@ elabDecl' _ info (PFix _ _ _)

156 = return () -- nothing to elaborate

157elabDecl' _ info (PSyntax _ p)

158 = return () -- nothing to elaborate

159−elabDecl' what info (PTy doc argdocs s f o n ty)

159+elabDecl' what info (PTy doc argdocs s f o n nfc ty)

160 | what /= EDefns

161 = do iLOG $ "Elaborating type decl " ++ show n ++ show o

162− elabType info s doc argdocs f o n ty

162+ elabType info s doc argdocs f o n nfc ty

163 return ()

164elabDecl' what info (PPostulate b doc s f o n ty)

165 | what /= EDefns

@@ -173,7 +173,7 @@ elabDecl' what info (PData doc argDocs s f co d)

173 elabData info s doc argDocs f co d

174 | otherwise

175 = do iLOG $ "Elaborating [type of] " ++ show (d_name d)

176− elabData info s doc argDocs f co (PLaterdecl (d_name d) (d_tcon d))

176+ elabData info s doc argDocs f co (PLaterdecl (d_name d) (d_name_fc d) (d_tcon d))

177elabDecl' what info d@(PClauses f o n ps)

178 | what /= ETypes

179 = do iLOG $ "Elaborating clause " ++ show n

@@ -232,17 +232,17 @@ elabDecl' what info (PNamespace n ps) = mapM_ (elabDecl' what ninfo) ps

232 ninfo = case namespace info of

233 Nothing -> info { namespace = Just [n] }

234 Just ns -> info { namespace = Just (n:ns) }

235−elabDecl' what info (PClass doc s f cs n ps pdocs fds ds cn cd)

235+elabDecl' what info (PClass doc s f cs n nfc ps pdocs fds ds cn cd)

236 | what /= EDefns

237 = do iLOG $ "Elaborating class " ++ show n

238− elabClass info (s { syn_params = [] }) doc f cs n ps pdocs fds ds cn cd

238+ elabClass info (s { syn_params = [] }) doc f cs n nfc ps pdocs fds ds cn cd

239−elabDecl' what info (PInstance doc argDocs s f cs n ps t expn ds)

239+elabDecl' what info (PInstance doc argDocs s f cs n nfc ps t expn ds)

240 = do iLOG $ "Elaborating instance " ++ show n

241− elabInstance info s doc argDocs what f cs n ps t expn ds

241+ elabInstance info s doc argDocs what f cs n nfc ps t expn ds

242−elabDecl' what info (PRecord doc rsyn fc opts name ps pdocs fs cname cdoc csyn)

242+elabDecl' what info (PRecord doc rsyn fc opts name nfc ps pdocs fs cname cdoc csyn)

243 | what /= ETypes

244 = do iLOG $ "Elaborating record " ++ show name

245− elabRecord info doc rsyn fc opts name ps pdocs fs cname cdoc csyn

245+ elabRecord info doc rsyn fc opts name nfc ps pdocs fs cname cdoc csyn

246{-

247 | otherwise

248 = do iLOG $ "Elaborating [type of] " ++ show tyn

src/Idris/ElabQuasiquote.hs+10−10

@@ -58,32 +58,32 @@ extractDoUnquotes :: Int -> PDo -> Elab' aux (PDo, [(Name, PTerm)])

58extractDoUnquotes d (DoExp fc tm)

59 = do (tm', ex) <- extractUnquotes d tm

60 return (DoExp fc tm', ex)

61−extractDoUnquotes d (DoBind fc n tm)

61+extractDoUnquotes d (DoBind fc n nfc tm)

62 = do (tm', ex) <- extractUnquotes d tm

63− return (DoBind fc n tm', ex)

63+ return (DoBind fc n nfc tm', ex)

64extractDoUnquotes d (DoBindP fc t t' alts)

65 = fail "Pattern-matching binds cannot be quasiquoted"

66−extractDoUnquotes d (DoLet fc n v b)

66+extractDoUnquotes d (DoLet fc n nfc v b)

67 = do (v', ex1) <- extractUnquotes d v

68 (b', ex2) <- extractUnquotes d b

69− return (DoLet fc n v' b', ex1 ++ ex2)

69+ return (DoLet fc n nfc v' b', ex1 ++ ex2)

70extractDoUnquotes d (DoLetP fc t t') = fail "Pattern-matching lets cannot be quasiquoted"

73extractUnquotes :: Int -> PTerm -> Elab' aux (PTerm, [(Name, PTerm)])

74−extractUnquotes n (PLam fc name ty body)

74+extractUnquotes n (PLam fc name nfc ty body)

75 = do (ty', ex1) <- extractUnquotes n ty

76 (body', ex2) <- extractUnquotes n body

77− return (PLam fc name ty' body', ex1 ++ ex2)

77+ return (PLam fc name nfc ty' body', ex1 ++ ex2)

78−extractUnquotes n (PPi plicity name ty body)

78+extractUnquotes n (PPi plicity name fc ty body)

79 = do (ty', ex1) <- extractUnquotes n ty

80 (body', ex2) <- extractUnquotes n body

81− return (PPi plicity name ty' body', ex1 ++ ex2)

81+ return (PPi plicity name fc ty' body', ex1 ++ ex2)

82−extractUnquotes n (PLet fc name ty val body)

82+extractUnquotes n (PLet fc name nfc ty val body)

83 = do (ty', ex1) <- extractUnquotes n ty

84 (val', ex2) <- extractUnquotes n val

85 (body', ex3) <- extractUnquotes n body

86− return (PLet fc name ty' val' body', ex1 ++ ex2 ++ ex3)

86+ return (PLet fc name nfc ty' val' body', ex1 ++ ex2 ++ ex3)

87extractUnquotes n (PTyped tm ty)

88 = do (tm', ex1) <- extractUnquotes n tm

89 (ty', ex2) <- extractUnquotes n ty

src/Idris/Error.hs+8−8

@@ -91,9 +91,9 @@ warnDisamb ist (PQuote _) = return ()

91warnDisamb ist (PRef _ _) = return ()

92warnDisamb ist (PInferRef _ _) = return ()

93warnDisamb ist (PPatvar _ _) = return ()

94−warnDisamb ist (PLam _ _ t b) = warnDisamb ist t >> warnDisamb ist b

94+warnDisamb ist (PLam _ _ _ t b) = warnDisamb ist t >> warnDisamb ist b

95−warnDisamb ist (PPi _ _ t b) = warnDisamb ist t >> warnDisamb ist b

95+warnDisamb ist (PPi _ _ _ t b) = warnDisamb ist t >> warnDisamb ist b

96−warnDisamb ist (PLet _ _ x t b) = warnDisamb ist x >> warnDisamb ist t >> warnDisamb ist b

96+warnDisamb ist (PLet _ _ _ x t b) = warnDisamb ist x >> warnDisamb ist t >> warnDisamb ist b

97warnDisamb ist (PTyped x t) = warnDisamb ist x >> warnDisamb ist t

98warnDisamb ist (PApp _ t args) = warnDisamb ist t >>

99 mapM_ (warnDisamb ist . getTm) args

@@ -111,17 +111,17 @@ warnDisamb ist (PPair _ _ x y) = warnDisamb ist x >> warnDisamb ist y

111warnDisamb ist (PDPair _ _ x y z) = warnDisamb ist x >> warnDisamb ist y >> warnDisamb ist z

112warnDisamb ist (PAlternative _ tms) = mapM_ (warnDisamb ist) tms

113warnDisamb ist (PHidden tm) = warnDisamb ist tm

114−warnDisamb ist PType = return ()

114+warnDisamb ist (PType _) = return ()

115warnDisamb ist (PUniverse _) = return ()

116warnDisamb ist (PGoal _ x _ y) = warnDisamb ist x >> warnDisamb ist y

117−warnDisamb ist (PConstant _) = return ()

117+warnDisamb ist (PConstant _ _) = return ()

118warnDisamb ist Placeholder = return ()

119warnDisamb ist (PDoBlock steps) = mapM_ wStep steps

120 where wStep (DoExp _ x) = warnDisamb ist x

121− wStep (DoBind _ _ x) = warnDisamb ist x

121+ wStep (DoBind _ _ _ x) = warnDisamb ist x

122 wStep (DoBindP _ x y cs) = warnDisamb ist x >> warnDisamb ist y >>

123− mapM_ (\(x,y)-> warnDisamb ist x >> warnDisamb ist y) cs

123+ mapM_ (\(x,y) -> warnDisamb ist x >> warnDisamb ist y) cs

124− wStep (DoLet _ _ x y) = warnDisamb ist x >> warnDisamb ist y

124+ wStep (DoLet _ _ _ x y) = warnDisamb ist x >> warnDisamb ist y

125 wStep (DoLetP _ x y) = warnDisamb ist x >> warnDisamb ist y

126warnDisamb ist (PIdiom _ x) = warnDisamb ist x

127warnDisamb ist (PReturn _) = return ()

src/Idris/IBC.hs+74−48

@@ -41,7 +41,7 @@ import Codec.Archive.Zip

41import Util.Zlib (decompressEither)

43ibcVersion :: Word16

44−ibcVersion = 107

44+ibcVersion = 108

46data IBCFile = IBCFile { ver :: Word16,

47 sourcefile :: FilePath,

@@ -1144,7 +1144,7 @@ instance (Binary t) => Binary (PDecl' t) where

1144 put x1

1145 put x2

1146 put x3

1147− PTy x1 x2 x3 x4 x5 x6 x7

1147+ PTy x1 x2 x3 x4 x5 x6 x7 x8

1148 -> do putWord8 1

1149 put x1

1150 put x2

@@ -1153,6 +1153,7 @@ instance (Binary t) => Binary (PDecl' t) where

1153 put x5

1154 put x6

1155 put x7

1156+ put x8

1156 PClauses x1 x2 x3 x4 -> do putWord8 2

1157 PClauses x1 x2 x3 x4 -> do putWord8 2

1157 put x1

1158 put x1

1158 put x2

1159 put x2

@@ -1173,7 +1174,7 @@ instance (Binary t) => Binary (PDecl' t) where

1173 PNamespace x1 x2 -> do putWord8 5

1174 PNamespace x1 x2 -> do putWord8 5

1174 put x1

1175 put x1

1175 put x2

1176 put x2

1176− PRecord x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 ->

1177+ PRecord x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 ->

1177 do putWord8 6

1178 do putWord8 6

1178 put x1

1179 put x1

1179 put x2

1180 put x2

@@ -1186,7 +1187,8 @@ instance (Binary t) => Binary (PDecl' t) where

1186 put x9

1187 put x9

1187 put x10

1188 put x10

1188 put x11

1189 put x11

1190+ put x12

1189− PClass x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11

1191+ PClass x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12

1190 -> do putWord8 7

1192 -> do putWord8 7

1191 put x1

1193 put x1

1192 put x2

1194 put x2

@@ -1199,7 +1201,8 @@ instance (Binary t) => Binary (PDecl' t) where

1199 put x9

1201 put x9

1200 put x10

1202 put x10

1201 put x11

1203 put x11

1204+ put x12

1202− PInstance x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 ->

1205+ PInstance x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 ->

1203 do putWord8 8

1206 do putWord8 8

1204 put x1

1207 put x1

1205 put x2

1208 put x2

@@ -1211,6 +1214,7 @@ instance (Binary t) => Binary (PDecl' t) where

1211 put x8

1214 put x8

1212 put x9

1215 put x9

1213 put x10

1216 put x10

1217+ put x11

1214 PDSL x1 x2 -> do putWord8 9

1218 PDSL x1 x2 -> do putWord8 9

1215 put x1

1219 put x1

1216 put x2

1220 put x2

@@ -1260,7 +1264,8 @@ instance (Binary t) => Binary (PDecl' t) where

1260 x5 <- get

1264 x5 <- get

1261 x6 <- get

1265 x6 <- get

1262 x7 <- get

1266 x7 <- get

1267+ x8 <- get

1263− return (PTy x1 x2 x3 x4 x5 x6 x7)

1268+ return (PTy x1 x2 x3 x4 x5 x6 x7 x8)

1264 2 -> do x1 <- get

1269 2 -> do x1 <- get

1265 x2 <- get

1270 x2 <- get

1266 x3 <- get

1271 x3 <- get

@@ -1291,7 +1296,8 @@ instance (Binary t) => Binary (PDecl' t) where

1291 x9 <- get

1296 x9 <- get

1292 x10 <- get

1297 x10 <- get

1293 x11 <- get

1298 x11 <- get

1299+ x12 <- get

1294− return (PRecord x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11)

1300+ return (PRecord x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12)

1295 7 -> do x1 <- get

1301 7 -> do x1 <- get

1296 x2 <- get

1302 x2 <- get

1297 x3 <- get

1303 x3 <- get

@@ -1303,7 +1309,8 @@ instance (Binary t) => Binary (PDecl' t) where

1303 x9 <- get

1309 x9 <- get

1304 x10 <- get

1310 x10 <- get

1305 x11 <- get

1311 x11 <- get

1312+ x12 <- get

1306− return (PClass x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11)

1313+ return (PClass x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12)

1307 8 -> do x1 <- get

1314 8 -> do x1 <- get

1308 x2 <- get

1315 x2 <- get

1309 x3 <- get

1316 x3 <- get

@@ -1314,7 +1321,8 @@ instance (Binary t) => Binary (PDecl' t) where

1314 x8 <- get

1321 x8 <- get

1315 x9 <- get

1322 x9 <- get

1316 x10 <- get

1323 x10 <- get

1324+ x11 <- get

1317− return (PInstance x1 x2 x3 x4 x5 x6 x7 x8 x9 x10)

1325+ return (PInstance x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11)

1318 9 -> do x1 <- get

1326 9 -> do x1 <- get

1319 x2 <- get

1327 x2 <- get

1320 return (PDSL x1 x2)

1328 return (PDSL x1 x2)

@@ -1457,23 +1465,27 @@ instance (Binary t) => Binary (PClause' t) where

1457instance (Binary t) => Binary (PData' t) where

1465instance (Binary t) => Binary (PData' t) where

1458 put x

1466 put x

1459 = case x of

1467 = case x of

1460− PDatadecl x1 x2 x3 -> do putWord8 0

1468+ PDatadecl x1 x2 x3 x4 -> do putWord8 0

1461− put x1

1469+ put x1

1462− put x2

1470+ put x2

1463− put x3

1471+ put x3

1472+ put x4

1464− PLaterdecl x1 x2 -> do putWord8 1

1473+ PLaterdecl x1 x2 x3 -> do putWord8 1

1465− put x1

1474+ put x1

1466− put x2

1475+ put x2

1476+ put x3

1467 get

1477 get

1468 = do i <- getWord8

1478 = do i <- getWord8

1469 case i of

1479 case i of

1470 0 -> do x1 <- get

1480 0 -> do x1 <- get

1471 x2 <- get

1481 x2 <- get

1472 x3 <- get

1482 x3 <- get

1483+ x4 <- get

1473− return (PDatadecl x1 x2 x3)

1484+ return (PDatadecl x1 x2 x3 x4)

1474 1 -> do x1 <- get

1485 1 -> do x1 <- get

1475 x2 <- get

1486 x2 <- get

1487+ x3 <- get

1476− return (PLaterdecl x1 x2)

1488+ return (PLaterdecl x1 x2 x3)

1477 _ -> error "Corrupted binary data for PData'"

1489 _ -> error "Corrupted binary data for PData'"

1478

1490

1479instance Binary PunInfo where

1491instance Binary PunInfo where

@@ -1504,22 +1516,25 @@ instance Binary PTerm where

1504 PPatvar x1 x2 -> do putWord8 3

1516 PPatvar x1 x2 -> do putWord8 3

1505 put x1

1517 put x1

1506 put x2

1518 put x2

1507− PLam x1 x2 x3 x4 -> do putWord8 4

1519+ PLam x1 x2 x3 x4 x5 -> do putWord8 4

1508− put x1

1509− put x2

1510− put x3

1511− put x4

1512− PPi x1 x2 x3 x4 -> do putWord8 5

1513− put x1

1514− put x2

1515− put x3

1516− put x4

1517− PLet x1 x2 x3 x4 x5 -> do putWord8 6

1518 put x1

1520 put x1

1519 put x2

1521 put x2

1520 put x3

1522 put x3

1521 put x4

1523 put x4

1522 put x5

1524 put x5

1525+ PPi x1 x2 x3 x4 x5 -> do putWord8 5

1526+ put x1

1527+ put x2

1528+ put x3

1529+ put x4

1530+ put x5

1531+ PLet x1 x2 x3 x4 x5 x6 -> do putWord8 6

1532+ put x1

1533+ put x2

1534+ put x3

1535+ put x4

1536+ put x5

1537+ put x6

1523 PTyped x1 x2 -> do putWord8 7

1538 PTyped x1 x2 -> do putWord8 7

1524 put x1

1539 put x1

1525 put x2

1540 put x2

@@ -1565,14 +1580,16 @@ instance Binary PTerm where

1565 put x2

1580 put x2

1566 PHidden x1 -> do putWord8 21

1581 PHidden x1 -> do putWord8 21

1567 put x1

1582 put x1

1568− PType -> putWord8 22

1583+ PType x1 -> do putWord8 22

1584+ put x1

1569 PGoal x1 x2 x3 x4 -> do putWord8 23

1585 PGoal x1 x2 x3 x4 -> do putWord8 23

1570 put x1

1586 put x1

1571 put x2

1587 put x2

1572 put x3

1588 put x3

1573 put x4

1589 put x4

1574− PConstant x1 -> do putWord8 24

1590+ PConstant x1 x2 -> do putWord8 24

1575− put x1

1591+ put x1

1592+ put x2

1576 Placeholder -> putWord8 25

1593 Placeholder -> putWord8 25

1577 PDoBlock x1 -> do putWord8 26

1594 PDoBlock x1 -> do putWord8 26

1578 put x1

1595 put x1

@@ -1639,18 +1656,21 @@ instance Binary PTerm where

1639 x2 <- get

1656 x2 <- get

1640 x3 <- get

1657 x3 <- get

1641 x4 <- get

1658 x4 <- get

1659+ x5 <- get

1642− return (PLam x1 x2 x3 x4)

1660+ return (PLam x1 x2 x3 x4 x5)

1643 5 -> do x1 <- get

1661 5 -> do x1 <- get

1644 x2 <- get

1662 x2 <- get

1645 x3 <- get

1663 x3 <- get

1646 x4 <- get

1664 x4 <- get

1665+ x5 <- get

1647− return (PPi x1 x2 x3 x4)

1666+ return (PPi x1 x2 x3 x4 x5)

1648 6 -> do x1 <- get

1667 6 -> do x1 <- get

1649 x2 <- get

1668 x2 <- get

1650 x3 <- get

1669 x3 <- get

1651 x4 <- get

1670 x4 <- get

1652 x5 <- get

1671 x5 <- get

1672+ x6 <- get

1653− return (PLet x1 x2 x3 x4 x5)

1673+ return (PLet x1 x2 x3 x4 x5 x6)

1654 7 -> do x1 <- get

1674 7 -> do x1 <- get

1655 x2 <- get

1675 x2 <- get

1656 return (PTyped x1 x2)

1676 return (PTyped x1 x2)

@@ -1695,14 +1715,16 @@ instance Binary PTerm where

1695 return (PAlternative x1 x2)

1715 return (PAlternative x1 x2)

1696 21 -> do x1 <- get

1716 21 -> do x1 <- get

1697 return (PHidden x1)

1717 return (PHidden x1)

1718+ 22 -> do x1 <- get

1698− 22 -> return PType

1719+ return (PType x1)

1699 23 -> do x1 <- get

1720 23 -> do x1 <- get

1700 x2 <- get

1721 x2 <- get

1701 x3 <- get

1722 x3 <- get

1702 x4 <- get

1723 x4 <- get

1703 return (PGoal x1 x2 x3 x4)

1724 return (PGoal x1 x2 x3 x4)

1704 24 -> do x1 <- get

1725 24 -> do x1 <- get

1726+ x2 <- get

1705− return (PConstant x1)

1727+ return (PConstant x1 x2)

1706 25 -> return Placeholder

1728 25 -> return Placeholder

1707 26 -> do x1 <- get

1729 26 -> do x1 <- get

1708 return (PDoBlock x1)

1730 return (PDoBlock x1)

@@ -1921,20 +1943,22 @@ instance (Binary t) => Binary (PDo' t) where

1921 DoExp x1 x2 -> do putWord8 0

1943 DoExp x1 x2 -> do putWord8 0

1922 put x1

1944 put x1

1923 put x2

1945 put x2

1924− DoBind x1 x2 x3 -> do putWord8 1

1946+ DoBind x1 x2 x3 x4 -> do putWord8 1

1925− put x1

1947+ put x1

1926− put x2

1948+ put x2

1927− put x3

1949+ put x3

1950+ put x4

1928 DoBindP x1 x2 x3 x4 -> do putWord8 2

1951 DoBindP x1 x2 x3 x4 -> do putWord8 2

1929 put x1

1952 put x1

1930 put x2

1953 put x2

1931 put x3

1954 put x3

1932 put x4

1955 put x4

1933− DoLet x1 x2 x3 x4 -> do putWord8 3

1956+ DoLet x1 x2 x3 x4 x5 -> do putWord8 3

1934− put x1

1957+ put x1

1935− put x2

1958+ put x2

1936− put x3

1959+ put x3

1937− put x4

1960+ put x4

1961+ put x5

1938 DoLetP x1 x2 x3 -> do putWord8 4

1962 DoLetP x1 x2 x3 -> do putWord8 4

1939 put x1

1963 put x1

1940 put x2

1964 put x2

@@ -1948,7 +1972,8 @@ instance (Binary t) => Binary (PDo' t) where

1948 1 -> do x1 <- get

1972 1 -> do x1 <- get

1949 x2 <- get

1973 x2 <- get

1950 x3 <- get

1974 x3 <- get

1975+ x4 <- get

1951− return (DoBind x1 x2 x3)

1976+ return (DoBind x1 x2 x3 x4)

1952 2 -> do x1 <- get

1977 2 -> do x1 <- get

1953 x2 <- get

1978 x2 <- get

1954 x3 <- get

1979 x3 <- get

@@ -1958,7 +1983,8 @@ instance (Binary t) => Binary (PDo' t) where

1958 x2 <- get

1983 x2 <- get

1959 x3 <- get

1984 x3 <- get

1960 x4 <- get

1985 x4 <- get

1986+ x5 <- get

1961− return (DoLet x1 x2 x3 x4)

1987+ return (DoLet x1 x2 x3 x4 x5)

1962 4 -> do x1 <- get

1988 4 -> do x1 <- get

1963 x2 <- get

1989 x2 <- get

1964 x3 <- get

1990 x3 <- get

src/Idris/IdeMode.hs+2

@@ -169,6 +169,8 @@ instance SExpable FC where

169 toSExp ((SymbolAtom "filename", StringAtom f),

170 (SymbolAtom "start", IntegerAtom (toInteger sl), IntegerAtom (toInteger sc)),

171 (SymbolAtom "end", IntegerAtom (toInteger el), IntegerAtom (toInteger ec)))

172+ toSExp NoFC = toSExp ([] :: [String])

173+ toSExp (FileFC f) = toSExp [(SymbolAtom "filename", StringAtom f)]

172

174

173escape :: String -> String

175escape :: String -> String

174escape = concatMap escapeChar

176escape = concatMap escapeChar

src/Idris/IdrisDoc.hs+10−10

@@ -291,9 +291,9 @@ extractPTermNames :: PTerm -- ^ Where to extract names from

291extractPTermNames (PRef _ n) = [n]

292extractPTermNames (PInferRef _ n) = [n]

293extractPTermNames (PPatvar _ n) = [n]

294−extractPTermNames (PLam _ n p1 p2) = n : concatMap extract [p1, p2]

294+extractPTermNames (PLam _ n _ p1 p2) = n : concatMap extract [p1, p2]

295−extractPTermNames (PPi _ n p1 p2) = n : concatMap extract [p1, p2]

295+extractPTermNames (PPi _ n _ p1 p2) = n : concatMap extract [p1, p2]

296−extractPTermNames (PLet _ n p1 p2 p3) = n : concatMap extract [p1, p2, p3]

296+extractPTermNames (PLet _ n _ p1 p2 p3) = n : concatMap extract [p1, p2, p3]

297extractPTermNames (PTyped p1 p2) = concatMap extract [p1, p2]

298extractPTermNames (PApp _ p pas) = let names = concatMap extractPArg pas

299 in (extract p) ++ names

@@ -338,13 +338,13 @@ extractPArg (PTacImplicit {pname=n, getScript=p1, getTm=p2})

338

339-- | Helper function for extractPTermNames

340extractPDo :: PDo -> [Name]

341−extractPDo (DoExp _ p) = extract p

341+extractPDo (DoExp _ p) = extract p

342−extractPDo (DoBind _ n p) = n : extract p

342+extractPDo (DoBind _ n _ p) = n : extract p

343−extractPDo (DoBindP _ p1 p2 ps) = let (ps1, ps2) = unzip ps

343+extractPDo (DoBindP _ p1 p2 ps) = let (ps1, ps2) = unzip ps

344− ps' = ps1 ++ ps2

344+ ps' = ps1 ++ ps2

345− in concatMap extract (p1 : p2 : ps')

345+ in concatMap extract (p1 : p2 : ps')

346−extractPDo (DoLet _ n p1 p2) = n : concatMap extract [p1, p2]

346+extractPDo (DoLet _ n _ p1 p2) = n : concatMap extract [p1, p2]

347−extractPDo (DoLetP _ p1 p2) = concatMap extract [p1, p2]

347+extractPDo (DoLetP _ p1 p2) = concatMap extract [p1, p2]

348

349-- | Helper function for extractPTermNames

350extractPTactic :: PTactic -> [Name]

src/Idris/Interactive.hs+6−6

@@ -197,9 +197,9 @@ doProofSearch fn updatefile rec l n hints (Just depth)

197 runIO $ copyFile fb fn

198 else iPrintResult newmv

199 where dropCtxt 0 sc = sc

200− dropCtxt i (PPi _ _ _ sc) = dropCtxt (i - 1) sc

200+ dropCtxt i (PPi _ _ _ _ sc) = dropCtxt (i - 1) sc

201− dropCtxt i (PLet _ _ _ _ sc) = dropCtxt (i - 1) sc

201+ dropCtxt i (PLet _ _ _ _ _ sc) = dropCtxt (i - 1) sc

202− dropCtxt i (PLam _ _ _ sc) = dropCtxt (i - 1) sc

202+ dropCtxt i (PLam _ _ _ _ sc) = dropCtxt (i - 1) sc

203 dropCtxt _ t = t

204

205 stripNS tm = mapPT dens tm where

@@ -304,11 +304,11 @@ makeLemma fn updatefile l n

304 appArgs skip i (Bind _ (Pi _ _ _) sc) = appArgs skip (i - 1) sc

305 appArgs skip i _ = ""

306

307− stripMNBind skip (PPi b n@(UN c) ty sc)

307+ stripMNBind skip (PPi b n@(UN c) _ ty sc)

308 | (thead c /= '_' && n `notElem` skip) ||

309 take 4 (str c) == "__pi" -- keep in type, but not in app

310− = PPi b n ty (stripMNBind skip sc)

310+ = PPi b n NoFC ty (stripMNBind skip sc)

311− stripMNBind skip (PPi b _ ty sc) = stripMNBind skip sc

311+ stripMNBind skip (PPi b _ _ ty sc) = stripMNBind skip sc

312 stripMNBind skip t = t

313

314 -- Guess which binders should be implicits in the generated lemma.

src/Idris/Output.hs+28−10

@@ -33,20 +33,20 @@ instance MonadException m => MonadException (ExceptT Err m) where

33pshow :: IState -> Err -> String

34pshow ist err = displayDecorated (consoleDecorate ist) .

35 renderPretty 1.0 80 .

36− fmap (fancifyAnnots ist) $ pprintErr ist err

36+ fmap (fancifyAnnots ist True) $ pprintErr ist err

38iWarn :: FC -> Doc OutputAnnotation -> Idris ()

39iWarn fc err =

40 do i <- getIState

41 case idris_outputmode i of

42 RawOutput h ->

43− do err' <- iRender . fmap (fancifyAnnots i) $

43+ do err' <- iRender . fmap (fancifyAnnots i True) $

44− if fc_fname fc /= ""

44+ case fc of

45− then text (show fc) <> colon <//> err

45+ FC fn _ _ | fn /= "" -> text (show fc) <> colon <//> err

46− else err

46+ _ -> err

47 runIO . hPutStrLn h $ displayDecorated (consoleDecorate i) err'

48 IdeMode n h ->

49− do err' <- iRender . fmap (fancifyAnnots i) $ err

49+ do err' <- iRender . fmap (fancifyAnnots i True) $ err

50 let (str, spans) = displaySpans err'

51 runIO . hPutStrLn h $

52 convSExp "warning" (fc_fname fc, fc_start fc, fc_end fc, str, spans) n

@@ -97,7 +97,7 @@ iRenderOutput doc =

97 RawOutput h -> do out <- iRender doc

98 runIO $ putStrLn (displayDecorated (consoleDecorate i) out)

99 IdeMode n h ->

100− do (str, spans) <- fmap displaySpans . iRender . fmap (fancifyAnnots i) $ doc

100+ do (str, spans) <- fmap displaySpans . iRender . fmap (fancifyAnnots i True) $ doc

101 let out = [toSExp str, toSExp spans]

102 runIO . hPutStrLn h $ convSExp "write-decorated" out n

103

@@ -112,7 +112,7 @@ ideModeReturnWithStatus status n h out = do

112 ist <- getIState

113 (str, spans) <- fmap displaySpans .

114 iRender .

115− fmap (fancifyAnnots ist) $

115+ fmap (fancifyAnnots ist True) $

116 out

117 let good = [SymbolAtom status, toSExp str, toSExp spans]

118 runIO . hPutStrLn h $ convSExp "return" good n

@@ -168,7 +168,7 @@ iputGoal g = do i <- getIState

168 case idris_outputmode i of

169 RawOutput h -> runIO $ hPutStrLn h (displayDecorated (consoleDecorate i) g)

170 IdeMode n h ->

171− let (str, spans) = displaySpans . fmap (fancifyAnnots i) $ g

171+ let (str, spans) = displaySpans . fmap (fancifyAnnots i True) $ g

172 goal = [toSExp str, toSExp spans]

173 in runIO . hPutStrLn h $ convSExp "write-goal" goal n

174

@@ -194,6 +194,24 @@ prettyDocumentedIst ist (name, ty, docs) =

194 where ppTm = pprintDelab ist

195 norm = normaliseAll (tt_ctxt ist) []

196

197+sendHighlighting :: [(FC, OutputAnnotation)] -> Idris ()

198+sendHighlighting [] = return ()

199+sendHighlighting highlights =

200+ do ist <- getIState

201+ case idris_outputmode ist of

202+ RawOutput _ -> return ()

203+ IdeMode n h ->

204+ let fancier = [ toSExp (fc, fancifyAnnots ist False annot)

205+ | (fc, annot) <- highlights, fullFC fc

206+ ]

207+ in runIO . hPutStrLn h $

208+ convSExp "output"

209+ (SymbolAtom "ok",

210+ (SymbolAtom "highlight-source", fancier)) n

211+

212+ where fullFC (FC _ _ _) = True

213+ fullFC _ = False

214+

197

215

198renderExternal :: OutputFmt -> Int -> Doc OutputAnnotation -> Idris String

216renderExternal :: OutputFmt -> Int -> Doc OutputAnnotation -> Idris String

199renderExternal fmt width doc

217renderExternal fmt width doc

@@ -203,7 +221,7 @@ renderExternal fmt width doc

203 return . wrap fmt .

221 return . wrap fmt .

204 displayDecorated (decorate fmt) .

222 displayDecorated (decorate fmt) .

205 renderPretty 1.0 width .

223 renderPretty 1.0 width .

206− fmap (fancifyAnnots ist) $

224+ fmap (fancifyAnnots ist True) $

207 doc

225 doc

208 where

226 where

209 decorate _ (AnnFC _) = id

227 decorate _ (AnnFC _) = id

src/Idris/ParseData.hs+51−49

@@ -53,29 +53,29 @@ record syn = do (doc, paramDocs, acc, opts) <- try (do

53 co <- recordI

54 return (doc', paramDocs', acc, opts ++ co))

55 fc <- getFC

56− tyn_in <- fnName

56+ (tyn_in, nfc) <- fnName

57 let tyn = expandNS syn tyn_in

58 let rsyn = syn { syn_namespace = show (nsroot tyn) :

59− syn_namespace syn }

59+ syn_namespace syn }

60 params <- manyTill (recordParameter rsyn) (reserved "where")

61− (fields, cname, cdoc) <- indentedBlockS $ agdaStyleBody rsyn tyn

61+ (fields, cname, cdoc) <- indentedBlockS $ recordBody rsyn tyn

62 case cname of

63− Just cn' -> accData acc tyn [cn']

63+ Just cn' -> accData acc tyn [fst cn']

64 Nothing -> return ()

65− return $ PRecord doc rsyn fc opts tyn params paramDocs fields cname cdoc syn

65+ return $ PRecord doc rsyn fc opts tyn nfc params paramDocs fields cname cdoc syn

66 <?> "record type declaration"

67− where

67+ where

68 getRecNames :: SyntaxInfo -> PTerm -> [Name]

69− getRecNames syn (PPi _ n _ sc) = [expandNS syn n, expandNS syn (mkType n)]

69+ getRecNames syn (PPi _ n _ _ sc) = [expandNS syn n, expandNS syn (mkType n)]

70− ++ getRecNames syn sc

70+ ++ getRecNames syn sc

71 getRecNames _ _ = []

73 toFreeze :: Maybe Accessibility -> Maybe Accessibility

74 toFreeze (Just Frozen) = Just Hidden

75 toFreeze x = x

77− agdaStyleBody :: SyntaxInfo -> Name -> IdrisParser ([((Maybe Name), Plicity, PTerm, Maybe (Docstring (Either Err PTerm)))], Maybe Name, Docstring (Either Err PTerm))

77+ recordBody :: SyntaxInfo -> Name -> IdrisParser ([((Maybe (Name, FC)), Plicity, PTerm, Maybe (Docstring (Either Err PTerm)))], Maybe (Name, FC), Docstring (Either Err PTerm))

78− agdaStyleBody syn tyn = do

78+ recordBody syn tyn = do

79 ist <- get

80 fc <- getFC

@@ -87,14 +87,14 @@ record syn = do (doc, paramDocs, acc, opts) <- try (do

87 let constructorDoc' = annotate syn ist constructorDoc

89 fields <- many . indented $ field syn

90−

90+

91 return (fields, constructorName, constructorDoc')

92 where

93− field :: SyntaxInfo -> IdrisParser ((Maybe Name), Plicity, PTerm, Maybe (Docstring (Either Err PTerm)))

93+ field :: SyntaxInfo -> IdrisParser ((Maybe (Name, FC)), Plicity, PTerm, Maybe (Docstring (Either Err PTerm)))

94 field syn = do doc <- optional docComment

95 c <- optional $ lchar '{'

96− n <- (do n <- fnName

96+ n <- (do (n, nfc) <- fnName

97− return $ Just (expandNS syn n))

97+ return $ Just (expandNS syn n, nfc))

98 <|> (do symbol "_"

99 return Nothing)

100 lchar ':'

@@ -106,8 +106,9 @@ record syn = do (doc, paramDocs, acc, opts) <- try (do

106 Nothing -> Nothing

107 return (n, p, t, doc')

108

109− constructor :: IdrisParser Name

109+ constructor :: IdrisParser (Name, FC)

110− constructor = reserved "constructor" *> fnName

110+ constructor = (reserved "constructor") *> fnName

111+

111

112

112 endPlicity :: Maybe Char -> IdrisParser Plicity

113 endPlicity :: Maybe Char -> IdrisParser Plicity

113 endPlicity (Just _) = do lchar '}'

114 endPlicity (Just _) = do lchar '}'

@@ -117,26 +118,27 @@ record syn = do (doc, paramDocs, acc, opts) <- try (do

117 annotate :: SyntaxInfo -> IState -> Docstring () -> Docstring (Either Err PTerm)

118 annotate :: SyntaxInfo -> IState -> Docstring () -> Docstring (Either Err PTerm)

118 annotate syn ist = annotCode $ tryFullExpr syn ist

119 annotate syn ist = annotCode $ tryFullExpr syn ist

119

120

120−recordParameter :: SyntaxInfo -> IdrisParser (Name, Plicity, PTerm)

121+recordParameter :: SyntaxInfo -> IdrisParser (Name, FC, Plicity, PTerm)

121recordParameter syn =

122recordParameter syn =

122 (do lchar '('

123 (do lchar '('

123− (n, pt) <- (namedTy syn <|> onlyName syn)

124+ (n, nfc, pt) <- (namedTy syn <|> onlyName syn)

124 lchar ')'

125 lchar ')'

125− return (n, expl, pt))

126+ return (n, nfc, expl, pt))

126 <|>

127 <|>

127− (do (n, pt) <- onlyName syn

128+ (do (n, nfc, pt) <- onlyName syn

128− return (n, expl, pt))

129+ return (n, nfc, expl, pt))

129 where

130 where

130− namedTy :: SyntaxInfo -> IdrisParser (Name, PTerm)

131+ namedTy :: SyntaxInfo -> IdrisParser (Name, FC, PTerm)

131 namedTy syn =

132 namedTy syn =

132− do n <- fnName

133+ do (n, nfc) <- fnName

133 lchar ':'

134 lchar ':'

134 ty <- typeExpr (allowImp syn)

135 ty <- typeExpr (allowImp syn)

135− return (expandNS syn n, ty)

136+ return (expandNS syn n, nfc, ty)

136− onlyName :: SyntaxInfo -> IdrisParser (Name, PTerm)

137+ onlyName :: SyntaxInfo -> IdrisParser (Name, FC, PTerm)

137 onlyName syn =

138 onlyName syn =

138− do n <- fnName

139+ do (n, nfc) <- fnName

140+ fc <- getFC

139− return (expandNS syn n, PType)

141+ return (expandNS syn n, nfc, PType fc)

140

142

141{- | Parses data declaration type (normal or codata)

143{- | Parses data declaration type (normal or codata)

142DataI ::= 'data' | 'codata';

144DataI ::= 'data' | 'codata';

@@ -189,20 +191,20 @@ data_ syn = do (doc, argDocs, acc, dataOpts) <- try (do

189 | (n, d) <- argDocs ]

191 | (n, d) <- argDocs ]

190 return (doc', argDocs', acc, dataOpts))

192 return (doc', argDocs', acc, dataOpts))

191 fc <- getFC

193 fc <- getFC

192− tyn_in <- fnName

194+ (tyn_in, nfc) <- fnName

193 (do try (lchar ':')

195 (do try (lchar ':')

194 popIndent

196 popIndent

195 ty <- typeExpr (allowImp syn)

197 ty <- typeExpr (allowImp syn)

196 let tyn = expandNS syn tyn_in

198 let tyn = expandNS syn tyn_in

197− option (PData doc argDocs syn fc dataOpts (PLaterdecl tyn ty)) (do

199+ option (PData doc argDocs syn fc dataOpts (PLaterdecl tyn nfc ty)) (do

198 reserved "where"

200 reserved "where"

199 cons <- indentedBlock (constructor syn)

201 cons <- indentedBlock (constructor syn)

200− accData acc tyn (map (\ (_, _, n, _, _, _) -> n) cons)

202+ accData acc tyn (map (\ (_, _, n, _, _, _, _) -> n) cons)

201− return $ PData doc argDocs syn fc dataOpts (PDatadecl tyn ty cons))) <|> (do

203+ return $ PData doc argDocs syn fc dataOpts (PDatadecl tyn nfc ty cons))) <|> (do

202− args <- many name

204+ args <- many (fst <$> name)

203− let ty = bindArgs (map (const PType) args) PType

205+ let ty = bindArgs (map (const (PType fc)) args) (PType fc)

204 let tyn = expandNS syn tyn_in

206 let tyn = expandNS syn tyn_in

205− option (PData doc argDocs syn fc dataOpts (PLaterdecl tyn ty)) (do

207+ option (PData doc argDocs syn fc dataOpts (PLaterdecl tyn nfc ty)) (do

206 try (lchar '=') <|> do reserved "where"

208 try (lchar '=') <|> do reserved "where"

207 let kw = (if DefaultEliminator `elem` dataOpts then "%elim" else "") ++ (if Codata `elem` dataOpts then "co" else "") ++ "data "

209 let kw = (if DefaultEliminator `elem` dataOpts then "%elim" else "") ++ (if Codata `elem` dataOpts then "co" else "") ++ "data "

208 let n = show tyn_in ++ " "

210 let n = show tyn_in ++ " "

@@ -217,18 +219,18 @@ data_ syn = do (doc, argDocs, acc, dataOpts) <- try (do

217 cons <- sepBy1 (simpleConstructor syn) (reservedOp "|")

219 cons <- sepBy1 (simpleConstructor syn) (reservedOp "|")

218 terminator

220 terminator

219 let conty = mkPApp fc (PRef fc tyn) (map (PRef fc) args)

221 let conty = mkPApp fc (PRef fc tyn) (map (PRef fc) args)

220− cons' <- mapM (\ (doc, argDocs, x, cargs, cfc, fs) ->

222+ cons' <- mapM (\ (doc, argDocs, x, xfc, cargs, cfc, fs) ->

221 do let cty = bindArgs cargs conty

223 do let cty = bindArgs cargs conty

222− return (doc, argDocs, x, cty, cfc, fs)) cons

224+ return (doc, argDocs, x, xfc, cty, cfc, fs)) cons

223− accData acc tyn (map (\ (_, _, n, _, _, _) -> n) cons')

225+ accData acc tyn (map (\ (_, _, n, _, _, _, _) -> n) cons')

224− return $ PData doc argDocs syn fc dataOpts (PDatadecl tyn ty cons')))

226+ return $ PData doc argDocs syn fc dataOpts (PDatadecl tyn nfc ty cons')))

225 <?> "data type declaration"

227 <?> "data type declaration"

226 where

228 where

227 mkPApp :: FC -> PTerm -> [PTerm] -> PTerm

229 mkPApp :: FC -> PTerm -> [PTerm] -> PTerm

228 mkPApp fc t [] = t

230 mkPApp fc t [] = t

229 mkPApp fc t xs = PApp fc t (map pexp xs)

231 mkPApp fc t xs = PApp fc t (map pexp xs)

230 bindArgs :: [PTerm] -> PTerm -> PTerm

232 bindArgs :: [PTerm] -> PTerm -> PTerm

231− bindArgs xs t = foldr (PPi expl (sMN 0 "_t")) t xs

233+ bindArgs xs t = foldr (PPi expl (sMN 0 "_t") NoFC) t xs

232 combineDataOpts :: DataOpts -> DataOpts

234 combineDataOpts :: DataOpts -> DataOpts

233 combineDataOpts opts = if Codata `elem` opts

235 combineDataOpts opts = if Codata `elem` opts

234 then delete DefaultEliminator opts

236 then delete DefaultEliminator opts

@@ -238,36 +240,36 @@ data_ syn = do (doc, argDocs, acc, dataOpts) <- try (do

238{- | Parses a type constructor declaration

240{- | Parses a type constructor declaration

239 Constructor ::= DocComment? FnName TypeSig;

241 Constructor ::= DocComment? FnName TypeSig;

240-}

242-}

241−constructor :: SyntaxInfo -> IdrisParser (Docstring (Either Err PTerm), [(Name, Docstring (Either Err PTerm))], Name, PTerm, FC, [Name])

243+constructor :: SyntaxInfo -> IdrisParser (Docstring (Either Err PTerm), [(Name, Docstring (Either Err PTerm))], Name, FC, PTerm, FC, [Name])

242constructor syn

244constructor syn

243 = do (doc, argDocs) <- option noDocs docComment

245 = do (doc, argDocs) <- option noDocs docComment

244− cn_in <- fnName; fc <- getFC

246+ (cn_in, nfc) <- fnName; fc <- getFC

245 let cn = expandNS syn cn_in

247 let cn = expandNS syn cn_in

246 lchar ':'

248 lchar ':'

247 fs <- option [] (do lchar '%'; reserved "erase"

249 fs <- option [] (do lchar '%'; reserved "erase"

248− sepBy1 name (lchar ','))

250+ sepBy1 (fst <$> name) (lchar ','))

249 ty <- typeExpr (allowImp syn)

251 ty <- typeExpr (allowImp syn)

250 ist <- get

252 ist <- get

251 let doc' = annotCode (tryFullExpr syn ist) doc

253 let doc' = annotCode (tryFullExpr syn ist) doc

252 argDocs' = [ (n, annotCode (tryFullExpr syn ist) d)

254 argDocs' = [ (n, annotCode (tryFullExpr syn ist) d)

253 | (n, d) <- argDocs ]

255 | (n, d) <- argDocs ]

254− return (doc', argDocs', cn, ty, fc, fs)

256+ return (doc', argDocs', cn, nfc, ty, fc, fs)

255 <?> "constructor"

257 <?> "constructor"

256

258

257{- | Parses a constructor for simple discriminated union data types

259{- | Parses a constructor for simple discriminated union data types

258 SimpleConstructor ::= FnName SimpleExpr* DocComment?

260 SimpleConstructor ::= FnName SimpleExpr* DocComment?

259-}

261-}

260−simpleConstructor :: SyntaxInfo -> IdrisParser (Docstring (Either Err PTerm), [(Name, Docstring (Either Err PTerm))], Name, [PTerm], FC, [Name])

262+simpleConstructor :: SyntaxInfo -> IdrisParser (Docstring (Either Err PTerm), [(Name, Docstring (Either Err PTerm))], Name, FC, [PTerm], FC, [Name])

261simpleConstructor syn

263simpleConstructor syn

262 = do (doc, _) <- option noDocs (try docComment)

264 = do (doc, _) <- option noDocs (try docComment)

263 ist <- get

265 ist <- get

264 let doc' = annotCode (tryFullExpr syn ist) doc

266 let doc' = annotCode (tryFullExpr syn ist) doc

265− cn_in <- fnName

267+ (cn_in, nfc) <- fnName

266 let cn = expandNS syn cn_in

268 let cn = expandNS syn cn_in

267 fc <- getFC

269 fc <- getFC

268 args <- many (do notEndApp

270 args <- many (do notEndApp

269 simpleExpr syn)

271 simpleExpr syn)

270− return (doc', [], cn, args, fc, [])

272+ return (doc', [], cn, nfc, args, fc, [])

271 <?> "constructor"

273 <?> "constructor"

272

274

273{- | Parses a dsl block declaration

275{- | Parses a dsl block declaration

@@ -275,7 +277,7 @@ DSL ::= 'dsl' FnName OpenBlock Overload'+ CloseBlock;

275 -}

277 -}

276dsl :: SyntaxInfo -> IdrisParser PDecl

278dsl :: SyntaxInfo -> IdrisParser PDecl

277dsl syn = do reserved "dsl"

279dsl syn = do reserved "dsl"

278− n <- fnName

280+ n <- fst <$> fnName

279 bs <- indentedBlock (overload syn)

281 bs <- indentedBlock (overload syn)

280 let dsl = mkDSL bs (dsl_info syn)

282 let dsl = mkDSL bs (dsl_info syn)

281 checkDSL dsl

283 checkDSL dsl

@@ -312,8 +314,8 @@ OverloadIdentifier ::= 'let' | Identifier;

312Overload ::= OverloadIdentifier '=' Expr;

314Overload ::= OverloadIdentifier '=' Expr;

313-}

315-}

314overload :: SyntaxInfo -> IdrisParser (String, PTerm)

316overload :: SyntaxInfo -> IdrisParser (String, PTerm)

315−overload syn = do o <- identifier <|> do reserved "let"

317+overload syn = do o <- (fst <$> identifier) <|> do reserved "let"

316− return "let"

318+ return "let"

317 if o `notElem` overloadable

319 if o `notElem` overloadable

318 then fail $ show o ++ " is not an overloading"

320 then fail $ show o ++ " is not an overloading"

319 else do

321 else do

src/Idris/ParseExpr.hs+122−112

@@ -142,7 +142,7 @@ extension syn ns rules =

142 return $ Just (n, SynTm tm)

143 extensionSymbol (SimpleExpr n) = do tm <- simpleExpr syn

144 return $ Just (n, SynTm tm)

145− extensionSymbol (Binding n) = do b <- name

145+ extensionSymbol (Binding n) = do b <- fst <$> name

146 return $ Just (n, SynBind b)

147 extensionSymbol (Symbol s) = do symbol s

148 return Nothing

@@ -164,13 +164,13 @@ extension syn ns rules =

164 update ns (PRef fc n) = case lookup n ns of

165 Just (SynTm t) -> t

166 _ -> PRef fc n

167− update ns (PLam fc n ty sc)

167+ update ns (PLam fc n nfc ty sc)

168− = PLam fc (updateB ns n) (update ns ty) (update (dropn n ns) sc)

168+ = PLam fc (updateB ns n) nfc (update ns ty) (update (dropn n ns) sc)

169− update ns (PPi p n ty sc)

169+ update ns (PPi p n fc ty sc)

170− = PPi (updTacImp ns p) (updateB ns n)

170+ = PPi (updTacImp ns p) (updateB ns n) fc

171 (update ns ty) (update (dropn n ns) sc)

172− update ns (PLet fc n ty val sc)

172+ update ns (PLet fc n nfc ty val sc)

173− = PLet fc (updateB ns n) (update ns ty)

173+ = PLet fc (updateB ns n) nfc (update ns ty)

174 (update ns val) (update (dropn n ns) sc)

175 update ns (PApp fc t args)

176 = PApp fc (update ns t) (map (fmap (update ns)) args)

@@ -188,9 +188,9 @@ extension syn ns rules =

188 update ns (PDoBlock ds) = PDoBlock $ upd ns ds

189 where upd :: [(Name, SynMatch)] -> [PDo] -> [PDo]

190 upd ns (DoExp fc t : ds) = DoExp fc (update ns t) : upd ns ds

191− upd ns (DoBind fc n t : ds) = DoBind fc n (update ns t) : upd (dropn n ns) ds

191+ upd ns (DoBind fc n nfc t : ds) = DoBind fc n nfc (update ns t) : upd (dropn n ns) ds

192− upd ns (DoLet fc n ty t : ds) = DoLet fc n (update ns ty) (update ns t)

192+ upd ns (DoLet fc n nfc ty t : ds) = DoLet fc n nfc (update ns ty) (update ns t)

193− : upd (dropn n ns) ds

193+ : upd (dropn n ns) ds

194 upd ns (DoBindP fc i t ts : ds)

195 = DoBindP fc (update ns i) (update ns t)

196 (map (\(l,r) -> (update ns l, update ns r)) ts)

@@ -324,29 +324,29 @@ SimpleExpr ::=

324simpleExpr :: SyntaxInfo -> IdrisParser PTerm

325simpleExpr syn =

326 try (simpleExternalExpr syn)

327− <|> do x <- try (lchar '?' *> name); return (PMetavar x)

327+ <|> do x <- try (lchar '?' *> (fst <$> name)); return (PMetavar x)

328 <|> do lchar '%'; fc <- getFC; reserved "instance"; return (PResolveTC fc)

329− <|> do reserved "elim_for"; fc <- getFC; t <- fnName; return (PRef fc (SN $ ElimN t))

329+ <|> do reserved "elim_for"; fc <- getFC; t <- fst <$> fnName; return (PRef fc (SN $ ElimN t))

330 <|> proofExpr syn

331 <|> tacticsExpr syn

332 <|> try (do reserved "Type"; symbol "*"; return $ PUniverse AllTypes)

333 <|> do reserved "AnyType"; return $ PUniverse AllTypes

334− <|> do reserved "Type"; return PType

334+ <|> PType <$> reservedFC "Type"

335 <|> do reserved "UniqueType"; return $ PUniverse UniqueType

336 <|> do reserved "NullType"; return $ PUniverse NullType

337− <|> do c <- constant

337+ <|> do (c, cfc) <- constant

338 fc <- getFC

339− return (modifyConst syn fc (PConstant c))

339+ return (modifyConst syn fc (PConstant cfc c))

340− <|> do symbol "'"; fc <- getFC; str <- name

340+ <|> do symbol "'"; fc <- getFC; str <- fst <$> name

341 return (PApp fc (PRef fc (sUN "Symbol_"))

342− [pexp (PConstant (Str (show str)))])

342+ [pexp (PConstant NoFC (Str (show str)))])

343− <|> do fc <- getFC

344− x <- fnName

343+ <|> do (x, fc) <- fnName

345− if inPattern syn

344+ if inPattern syn

346 then option (PRef fc x)

345 then option (PRef fc x)

347 (do reservedOp "@"

346 (do reservedOp "@"

348 s <- simpleExpr syn

347 s <- simpleExpr syn

348+ fcIn <- getFC

349− return (PAs fc x s))

349+ return (PAs fcIn x s))

350 else return (PRef fc x)

351 <|> idiom syn

352 <|> listExpr syn

@@ -368,8 +368,9 @@ Bracketed ::= '(' Bracketed'

368@

369 -}

370bracketed :: SyntaxInfo -> IdrisParser PTerm

371+bracketed syn = do fc <- getFC

371−bracketed syn = do lchar '(' <?> "parenthesized expression"

372+ lchar '(' <?> "parenthesized expression"

372− bracketed' syn

373+ bracketed' fc syn

373{- |Parses the rest of an expression in braces

374{- |Parses the rest of an expression in braces

374@

375@

375Bracketed' ::=

376Bracketed' ::=

@@ -383,12 +384,12 @@ Bracketed' ::=

383 ;

384 ;

384@

385@

385-}

386-}

386−bracketed' :: SyntaxInfo -> IdrisParser PTerm

387+bracketed' :: FC -> SyntaxInfo -> IdrisParser PTerm

387−bracketed' syn =

388+bracketed' open syn =

388− do lchar ')'

389− fc <- getFC

389+ do (FC f start (l, c)) <- getFC

390+ lchar ')'

390− return $ PTrue fc TypeOrTerm

391+ return $ PTrue (spanFC open (FC f start (l, c+1))) TypeOrTerm

391− <|> try (do ln <- name; lchar ':';

392+ <|> try (do ln <- fst <$> name; lchar ':';

392 lty <- expr syn

393 lty <- expr syn

393 reservedOp "**"

394 reservedOp "**"

394 fc <- getFC

395 fc <- getFC

@@ -399,7 +400,7 @@ bracketed' syn =

399 -- No prefix operators! (bit of a hack here...)

400 -- No prefix operators! (bit of a hack here...)

400 if (o == "-" || o == "!")

401 if (o == "-" || o == "!")

401 then fail "minus not allowed in section"

402 then fail "minus not allowed in section"

402− else return $ PLam fc (sMN 1000 "ARG") Placeholder

403+ else return $ PLam fc (sMN 1000 "ARG") NoFC Placeholder

403 (PApp fc (PRef fc (sUN o)) [pexp (PRef fc (sMN 1000 "ARG")),

404 (PApp fc (PRef fc (sUN o)) [pexp (PRef fc (sMN 1000 "ARG")),

404 pexp e]))

405 pexp e]))

405 <|> try (do l <- simpleExpr syn

406 <|> try (do l <- simpleExpr syn

@@ -409,7 +410,7 @@ bracketed' syn =

409 fc0 <- getFC

410 fc0 <- getFC

410 case op of

411 case op of

411 Nothing -> bracketedExpr syn l

412 Nothing -> bracketedExpr syn l

412− Just o -> return $ PLam fc0 (sMN 1000 "ARG") Placeholder

413+ Just o -> return $ PLam fc0 (sMN 1000 "ARG") NoFC Placeholder

413 (PApp fc0 (PRef fc0 (sUN o)) [pexp l,

414 (PApp fc0 (PRef fc0 (sUN o)) [pexp l,

414 pexp (PRef fc0 (sMN 1000 "ARG"))]))

415 pexp (PRef fc0 (sMN 1000 "ARG"))]))

415 <|> do l <- expr syn

416 <|> do l <- expr syn

@@ -441,19 +442,19 @@ bracketedExpr syn e =

441-- name suggests, rather than Int

442-- name suggests, rather than Int

442{-| Finds optimal type for integer constant -}

443{-| Finds optimal type for integer constant -}

443modifyConst :: SyntaxInfo -> FC -> PTerm -> PTerm

444modifyConst :: SyntaxInfo -> FC -> PTerm -> PTerm

444−modifyConst syn fc (PConstant (BI x))

445+modifyConst syn fc (PConstant inFC (BI x))

445 | not (inPattern syn)

446 | not (inPattern syn)

446 = PAlternative False

447 = PAlternative False

447− (PApp fc (PRef fc (sUN "fromInteger")) [pexp (PConstant (BI (fromInteger x)))]

448+ (PApp fc (PRef fc (sUN "fromInteger")) [pexp (PConstant NoFC (BI (fromInteger x)))]

448 : consts)

449 : consts)

449 | otherwise = PAlternative False consts

450 | otherwise = PAlternative False consts

450 where

451 where

451− consts = [ PConstant (BI x)

452+ consts = [ PConstant inFC (BI x)

452− , PConstant (I (fromInteger x))

453+ , PConstant inFC (I (fromInteger x))

453− , PConstant (B8 (fromInteger x))

454+ , PConstant inFC (B8 (fromInteger x))

454− , PConstant (B16 (fromInteger x))

455+ , PConstant inFC (B16 (fromInteger x))

455− , PConstant (B32 (fromInteger x))

456+ , PConstant inFC (B32 (fromInteger x))

456− , PConstant (B64 (fromInteger x))

457+ , PConstant inFC (B64 (fromInteger x))

457 ]

458 ]

458modifyConst syn fc x = x

459modifyConst syn fc x = x

459

460

@@ -518,7 +519,7 @@ Disamb ::=

518-}

519-}

519disamb :: SyntaxInfo -> IdrisParser PTerm

520disamb :: SyntaxInfo -> IdrisParser PTerm

520disamb syn = do reserved "with";

521disamb syn = do reserved "with";

521− ns <- sepBy1 name (lchar ',')

522+ ns <- sepBy1 (fst <$> name) (lchar ',')

522 tm <- expr' syn

523 tm <- expr' syn

523 return (PDisamb (map tons ns) tm)

524 return (PDisamb (map tons ns) tm)

524 <?> "unification log expression"

525 <?> "unification log expression"

@@ -553,8 +554,8 @@ app :: SyntaxInfo -> IdrisParser PTerm

553app syn = do f <- simpleExpr syn

554app syn = do f <- simpleExpr syn

554 (do try $ reservedOp "<=="

555 (do try $ reservedOp "<=="

555 fc <- getFC

556 fc <- getFC

556− ff <- fnName

557+ ff <- fst <$> fnName

557− return (PLet fc (sMN 0 "match")

558+ return (PLet fc (sMN 0 "match") NoFC

558 f

559 f

559 (PMatchApp fc ff)

560 (PMatchApp fc ff)

560 (PRef fc (sMN 0 "match")))

561 (PRef fc (sMN 0 "match")))

@@ -592,7 +593,7 @@ ImplicitArg ::=

592-}

593-}

593implicitArg :: SyntaxInfo -> IdrisParser PArg

594implicitArg :: SyntaxInfo -> IdrisParser PArg

594implicitArg syn = do lchar '{'

595implicitArg syn = do lchar '{'

595− n <- name

596+ n <- fst <$> name

596 fc <- getFC

597 fc <- getFC

597 v <- option (PRef fc n) (do lchar '='

598 v <- option (PRef fc n) (do lchar '='

598 expr syn)

599 expr syn)

@@ -649,7 +650,7 @@ unquote syn = do guard (syn_in_quasiquote syn > 0)

649-}

650-}

650namequote :: SyntaxInfo -> IdrisParser PTerm

651namequote :: SyntaxInfo -> IdrisParser PTerm

651namequote syn = do symbol "`{"

652namequote syn = do symbol "`{"

652− n <- fnName

653+ n <- fst <$> fnName

653 symbol "}"

654 symbol "}"

654 return $ PQuoteName n

655 return $ PQuoteName n

655 <?> "quoted name"

656 <?> "quoted name"

@@ -684,13 +685,13 @@ recordType syn =

684 Left fields ->

685 Left fields ->

685 case rec of

686 case rec of

686 Nothing ->

687 Nothing ->

687− return (PLam fc (sMN 0 "fldx") Placeholder

688+ return (PLam fc (sMN 0 "fldx") NoFC Placeholder

688 (applyAll fc fields (PRef fc (sMN 0 "fldx"))))

689 (applyAll fc fields (PRef fc (sMN 0 "fldx"))))

689 Just v -> return (applyAll fc fields v)

690 Just v -> return (applyAll fc fields v)

690 Right fields ->

691 Right fields ->

691 case rec of

692 case rec of

692 Nothing ->

693 Nothing ->

693− return (PLam fc (sMN 0 "fldx") Placeholder

694+ return (PLam fc (sMN 0 "fldx") NoFC Placeholder

694 (getAll fc (reverse fields)

695 (getAll fc (reverse fields)

695 (PRef fc (sMN 0 "fldx"))))

696 (PRef fc (sMN 0 "fldx"))))

696 Just v -> return (getAll fc (reverse fields) v)

697 Just v -> return (getAll fc (reverse fields) v)

@@ -704,7 +705,7 @@ recordType syn =

704 <?> "field setter"

705 <?> "field setter"

705

706

706 fieldGet :: IdrisParser [Name]

707 fieldGet :: IdrisParser [Name]

707− fieldGet = sepBy1 fnName (symbol "->")

708+ fieldGet = sepBy1 (fst <$> fnName) (symbol "->")

708

709

709 fieldGetOrSet :: IdrisParser (Either [([Name], PTerm)] [Name])

710 fieldGetOrSet :: IdrisParser (Either [([Name], PTerm)] [Name])

710 fieldGetOrSet = try (do fs <- sepBy1 fieldSet (lchar ',')

711 fieldGetOrSet = try (do fs <- sepBy1 fieldSet (lchar ',')

@@ -787,7 +788,7 @@ lambda syn = do lchar '\\' <?> "lambda expression"

787 where pmList :: [(Int, (FC, PTerm))] -> PTerm -> PTerm

788 where pmList :: [(Int, (FC, PTerm))] -> PTerm -> PTerm

788 pmList [] sc = sc

789 pmList [] sc = sc

789 pmList ((i, (fc, x)) : xs) sc

790 pmList ((i, (fc, x)) : xs) sc

790− = PLam fc (sMN i "lamp") Placeholder

791+ = PLam fc (sMN i "lamp") NoFC Placeholder

791 (PCase fc (PRef fc (sMN i "lamp"))

792 (PCase fc (PRef fc (sMN i "lamp"))

792 [(x, pmList xs sc)])

793 [(x, pmList xs sc)])

793 lambdaTail :: IdrisParser PTerm

794 lambdaTail :: IdrisParser PTerm

@@ -829,12 +830,12 @@ let_ syn = try (do reserved "let"

829 return (buildLets ls sc))

830 return (buildLets ls sc))

830 <?> "let binding"

831 <?> "let binding"

831 where buildLets [] sc = sc

832 where buildLets [] sc = sc

832− buildLets ((fc,PRef _ n,ty,v,[]):ls) sc

833+ buildLets ((fc, PRef nfc n, ty, v, []) : ls) sc

833− = PLet fc n ty v (buildLets ls sc)

834+ = PLet fc n nfc ty v (buildLets ls sc)

834− buildLets ((fc,pat,ty,v,alts):ls) sc

835+ buildLets ((fc, pat, ty, v, alts) : ls) sc

835 = PCase fc v ((pat, buildLets ls sc) : alts)

836 = PCase fc v ((pat, buildLets ls sc) : alts)

836

837

837−let_binding syn = do fc <- getFC;

838+let_binding syn = do fc <- getFC;

838 pat <- expr' (syn { inPattern = True })

839 pat <- expr' (syn { inPattern = True })

839 ty <- option Placeholder (do lchar ':'; expr' syn)

840 ty <- option Placeholder (do lchar ':'; expr' syn)

840 lchar '='

841 lchar '='

@@ -870,7 +871,7 @@ QuoteGoal ::=

870@

871@

871 -}

872 -}

872quoteGoal :: SyntaxInfo -> IdrisParser PTerm

873quoteGoal :: SyntaxInfo -> IdrisParser PTerm

873−quoteGoal syn = do reserved "quoteGoal"; n <- name;

874+quoteGoal syn = do reserved "quoteGoal"; n <- fst <$> name;

874 reserved "by"

875 reserved "by"

875 r <- expr syn

876 r <- expr syn

876 reserved "in"

877 reserved "in"

@@ -942,7 +943,7 @@ normalImplicit opts st syn = do

942 return (bindList (PPi im) xt

943 return (bindList (PPi im) xt

943 (bindList (PPi cl) cs sc))

944 (bindList (PPi cl) cs sc))

944

945

945−implicitPi opts st syn =

946+implicitPi opts st syn =

946 autoImplicit opts st syn

947 autoImplicit opts st syn

947 <|> defaultImplicit opts st syn

948 <|> defaultImplicit opts st syn

948 <|> normalImplicit opts st syn

949 <|> normalImplicit opts st syn

@@ -951,7 +952,7 @@ unboundPi opts st syn = do

951 x <- opExpr syn

952 x <- opExpr syn

952 (do binder <- bindsymbol opts st syn

953 (do binder <- bindsymbol opts st syn

953 sc <- expr syn

954 sc <- expr syn

954− return (PPi binder (sUN "__pi_arg") x sc))

955+ return (PPi binder (sUN "__pi_arg") NoFC x sc))

955 <|> return x

956 <|> return x

956

957

957pi :: SyntaxInfo -> IdrisParser PTerm

958pi :: SyntaxInfo -> IdrisParser PTerm

@@ -983,11 +984,11 @@ ConstraintList ::=

983 ;

984 ;

984@

985@

985-}

986-}

986−constraintList :: SyntaxInfo -> IdrisParser [(Name, PTerm)]

987+constraintList :: SyntaxInfo -> IdrisParser [(Name, FC, PTerm)]

987constraintList syn = try (constraintList1 syn)

988constraintList syn = try (constraintList1 syn)

988 <|> return []

989 <|> return []

989

990

990−constraintList1 :: SyntaxInfo -> IdrisParser [(Name, PTerm)]

991+constraintList1 :: SyntaxInfo -> IdrisParser [(Name, FC, PTerm)]

991constraintList1 syn = try (do lchar '('

992constraintList1 syn = try (do lchar '('

992 tys <- sepBy1 nexpr (lchar ',')

993 tys <- sepBy1 nexpr (lchar ',')

993 lchar ')'

994 lchar ')'

@@ -995,13 +996,13 @@ constraintList1 syn = try (do lchar '('

995 return tys)

996 return tys)

996 <|> try (do t <- opExpr (disallowImp syn)

997 <|> try (do t <- opExpr (disallowImp syn)

997 reservedOp "=>"

998 reservedOp "=>"

998− return [(defname, t)])

999+ return [(defname, NoFC, t)])

999 <?> "type constraint list"

1000 <?> "type constraint list"

1000− where nexpr = try (do n <- name; lchar ':'

1001+ where nexpr = try (do (n, fc) <- name; lchar ':'

1001 e <- expr syn

1002 e <- expr syn

1002− return (n, e))

1003+ return (n, fc, e))

1003 <|> do e <- expr syn

1004 <|> do e <- expr syn

1004− return (defname, e)

1005+ return (defname, NoFC, e)

1005 defname = sMN 0 "constrarg"

1006 defname = sMN 0 "constrarg"

1006

1007

1007{- | Parses a type declaration list

1008{- | Parses a type declaration list

@@ -1019,16 +1020,16 @@ FunctionSignatureList ::=

1019 ;

1020 ;

1020@

1021@

1021-}

1022-}

1022−typeDeclList :: SyntaxInfo -> IdrisParser [(Name, PTerm)]

1023+typeDeclList :: SyntaxInfo -> IdrisParser [(Name, FC, PTerm)]

1023−typeDeclList syn = try (sepBy1 (do x <- fnName

1024+typeDeclList syn = try (sepBy1 (do (x, xfc) <- fnName

1024 lchar ':'

1025 lchar ':'

1025 t <- typeExpr (disallowImp syn)

1026 t <- typeExpr (disallowImp syn)

1026− return (x,t))

1027+ return (x, xfc, t))

1027 (lchar ','))

1028 (lchar ','))

1028 <|> do ns <- sepBy1 name (lchar ',')

1029 <|> do ns <- sepBy1 name (lchar ',')

1029 lchar ':'

1030 lchar ':'

1030 t <- typeExpr (disallowImp syn)

1031 t <- typeExpr (disallowImp syn)

1031− return (map (\x -> (x, t)) ns)

1032+ return (map (\(x, xfc) -> (x, xfc, t)) ns)

1032 <?> "type declaration list"

1033 <?> "type declaration list"

1033

1034

1034{- | Parses a type declaration list with optional parameters

1035{- | Parses a type declaration list with optional parameters

@@ -1043,17 +1044,17 @@ TypeOptDeclList ::=

1043NameOrPlaceHolder ::= Name | '_';

1044NameOrPlaceHolder ::= Name | '_';

1044@

1045@

1045-}

1046-}

1046−tyOptDeclList :: SyntaxInfo -> IdrisParser [(Name, PTerm)]

1047+tyOptDeclList :: SyntaxInfo -> IdrisParser [(Name, FC, PTerm)]

1047−tyOptDeclList syn = sepBy1 (do x <- nameOrPlaceholder

1048+tyOptDeclList syn = sepBy1 (do (x, fc) <- nameOrPlaceholder

1048 t <- option Placeholder (do lchar ':'

1049 t <- option Placeholder (do lchar ':'

1049 expr syn)

1050 expr syn)

1050− return (x,t))

1051+ return (x, fc, t))

1051 (lchar ',')

1052 (lchar ',')

1052 <?> "type declaration list"

1053 <?> "type declaration list"

1053− where nameOrPlaceholder :: IdrisParser Name

1054+ where nameOrPlaceholder :: IdrisParser (Name, FC)

1054 nameOrPlaceholder = fnName

1055 nameOrPlaceholder = fnName

1055 <|> do symbol "_"

1056 <|> do symbol "_"

1056− return (sMN 0 "underscore")

1057+ return (sMN 0 "underscore", NoFC)

1057 <?> "name or placeholder"

1058 <?> "name or placeholder"

1058

1059

1059{- | Parses a list literal expression e.g. [1,2,3] or a comprehension [ (x, y) | x <- xs , y <- ys ]

1060{- | Parses a list literal expression e.g. [1,2,3] or a comprehension [ (x, y) | x <- xs , y <- ys ]

@@ -1078,23 +1079,28 @@ ExprList ::=

1078@

1079@

1079 -}

1080 -}

1080listExpr :: SyntaxInfo -> IdrisParser PTerm

1081listExpr :: SyntaxInfo -> IdrisParser PTerm

1082+listExpr syn = do (FC f (l, c) _) <- getFC

1081−listExpr syn = do lchar '['; fc <- getFC;

1083+ lchar '['; fc <- getFC;

1082− try ((lchar ']' <?> "end of list expression") *> return (mkList fc [])) <|> (do

1084+ (try . token $ do (char ']' <?> "end of list expression")

1085+ (FC _ _ (l', c')) <- getFC

1086+ return (mkNil (FC f (l, c) (l', c'))))

1083− x <- expr syn <?> "expression"

1087+ <|> (do x <- expr syn <?> "expression"

1084− (do try (lchar '|') <?> "list comprehension"

1088+ (do try (lchar '|') <?> "list comprehension"

1085− qs <- sepBy1 (do_ syn) (lchar ',')

1089+ qs <- sepBy1 (do_ syn) (lchar ',')

1086− lchar ']'

1090+ lchar ']'

1087− return (PDoBlock (map addGuard qs ++

1091+ return (PDoBlock (map addGuard qs ++

1088− [DoExp fc (PApp fc (PRef fc (sUN "return"))

1092+ [DoExp fc (PApp fc (PRef fc (sUN "return"))

1089− [pexp x])]))) <|> (do

1093+ [pexp x])]))) <|>

1090− xs <- many ((lchar ',' <?> "list element") *> expr syn)

1094+ (do xs <- many ((lchar ',' <?> "list element") *> expr syn)

1091− lchar ']' <?> "end of list expression"

1095+ lchar ']' <?> "end of list expression"

1092− return (mkList fc (x:xs))))

1096+ return (mkList fc (x:xs))))

1093 <?> "list expression"

1097 <?> "list expression"

1094 where

1098 where

1099+ mkNil :: FC -> PTerm

1100+ mkNil fc = PRef fc (sUN "Nil")

1095 mkList :: FC -> [PTerm] -> PTerm

1101 mkList :: FC -> [PTerm] -> PTerm

1096− mkList fc [] = PRef fc (sUN "Nil")

1102+ mkList fc [] = PRef NoFC (sUN "Nil")

1097− mkList fc (x : xs) = PApp fc (PRef fc (sUN "::")) [pexp x, pexp (mkList fc xs)]

1103+ mkList fc (x : xs) = PApp fc (PRef NoFC (sUN "::")) [pexp x, pexp (mkList fc xs)]

1098 addGuard :: PDo -> PDo

1104 addGuard :: PDo -> PDo

1099 addGuard (DoExp fc e) = DoExp fc (PApp fc (PRef fc (sUN "guard"))

1105 addGuard (DoExp fc e) = DoExp fc (PApp fc (PRef fc (sUN "guard"))

1100 [pexp e])

1106 [pexp e])

@@ -1132,27 +1138,27 @@ Do ::=

1132do_ :: SyntaxInfo -> IdrisParser PDo

1138do_ :: SyntaxInfo -> IdrisParser PDo

1133do_ syn

1139do_ syn

1134 = try (do reserved "let"

1140 = try (do reserved "let"

1135− i <- name

1141+ (i, ifc) <- name

1136 ty <- option Placeholder (do lchar ':'

1142 ty <- option Placeholder (do lchar ':'

1137 expr' syn)

1143 expr' syn)

1138 reservedOp "="

1144 reservedOp "="

1139 fc <- getFC

1145 fc <- getFC

1140 e <- expr syn

1146 e <- expr syn

1141− return (DoLet fc i ty e))

1147+ return (DoLet fc i ifc ty e))

1142 <|> try (do reserved "let"

1148 <|> try (do reserved "let"

1143 i <- expr' syn

1149 i <- expr' syn

1144 reservedOp "="

1150 reservedOp "="

1145 fc <- getFC

1151 fc <- getFC

1146 sc <- expr syn

1152 sc <- expr syn

1147 return (DoLetP fc i sc))

1153 return (DoLetP fc i sc))

1148− <|> try (do i <- name

1154+ <|> try (do (i, ifc) <- name

1149 symbol "<-"

1155 symbol "<-"

1150 fc <- getFC

1156 fc <- getFC

1151 e <- expr syn;

1157 e <- expr syn;

1152− option (DoBind fc i e)

1158+ option (DoBind fc i ifc e)

1153 (do lchar '|'

1159 (do lchar '|'

1154 ts <- sepBy1 (do_alt syn) (lchar '|')

1160 ts <- sepBy1 (do_alt syn) (lchar '|')

1155− return (DoBindP fc (PRef fc i) e ts)))

1161+ return (DoBindP fc (PRef ifc i) e ts)))

1156 <|> try (do i <- expr' syn

1162 <|> try (do i <- expr' syn

1157 symbol "<-"

1163 symbol "<-"

1158 fc <- getFC

1164 fc <- getFC

@@ -1215,14 +1221,12 @@ Constant ::=

1215-}

1221-}

1216

1222

1217constants :: [(String, Idris.Core.TT.Const)]

1223constants :: [(String, Idris.Core.TT.Const)]

1218−constants =

1224+constants =

1219 [ ("Integer", AType (ATInt ITBig))

1225 [ ("Integer", AType (ATInt ITBig))

1220 , ("Int", AType (ATInt ITNative))

1226 , ("Int", AType (ATInt ITNative))

1221 , ("Char", AType (ATInt ITChar))

1227 , ("Char", AType (ATInt ITChar))

1222 , ("Double", AType ATFloat)

1228 , ("Double", AType ATFloat)

1223 , ("String", StrType)

1229 , ("String", StrType)

1224−-- , ("Ptr", PtrType)

1225−-- , ("ManagedPtr", ManagedPtrType)

1226 , ("prim__WorldType", WorldType)

1230 , ("prim__WorldType", WorldType)

1227 , ("prim__TheWorld", TheWorld)

1231 , ("prim__TheWorld", TheWorld)

1228 , ("Bits8", AType (ATInt (ITFixed IT8)))

1232 , ("Bits8", AType (ATInt (ITFixed IT8)))

@@ -1230,14 +1234,17 @@ constants =

1230 , ("Bits32", AType (ATInt (ITFixed IT32)))

1234 , ("Bits32", AType (ATInt (ITFixed IT32)))

1231 , ("Bits64", AType (ATInt (ITFixed IT64)))

1235 , ("Bits64", AType (ATInt (ITFixed IT64)))

1232 ]

1236 ]

1233−

1237+

1238+-- | Parse a constant and its source span

1234−constant :: IdrisParser Idris.Core.TT.Const

1239+constant :: IdrisParser (Idris.Core.TT.Const, FC)

1235−constant = choice [ do reserved name; return ty | (name, ty) <- constants ]

1240+constant = choice [ do fc <- reservedFC name; return (ty, fc)

1241+ | (name, ty) <- constants

1242+ ]

1236− <|> do f <- try float; return $ Fl f

1243+ <|> do (f, fc) <- try float; return (Fl f, fc)

1237− <|> do i <- natural; return $ BI i

1244+ <|> do (i, fc) <- natural; return (BI i, fc)

1238− <|> do s <- verbatimStringLiteral; return $ Str s

1245+ <|> do (s, fc) <- verbatimStringLiteral; return (Str s, fc)

1239− <|> do s <- stringLiteral; return $ Str s

1246+ <|> do (s, fc) <- stringLiteral; return (Str s, fc)

1240− <|> do c <- try charLiteral; return $ Ch c --Currently ambigous with symbols

1247+ <|> do (c, fc) <- try charLiteral; return (Ch c, fc) --Currently ambigous with symbols

1241 <?> "constant or literal"

1248 <?> "constant or literal"

1242

1249

1243{- | Parses a verbatim multi-line string literal (triple-quoted)

1250{- | Parses a verbatim multi-line string literal (triple-quoted)

@@ -1248,9 +1255,12 @@ VerbatimString_t ::=

1248;

1255;

1249@

1256@

1250 -}

1257 -}

1251−verbatimStringLiteral :: MonadicParsing m => m String

1258+verbatimStringLiteral :: MonadicParsing m => m (String, FC)

1252−verbatimStringLiteral = token $ do try $ string "\"\"\""

1259+verbatimStringLiteral = token $ do (FC f start _) <- getFC

1260+ try $ string "\"\"\""

1253− manyTill anyChar $ try (string "\"\"\"")

1261+ str <- manyTill anyChar $ try (string "\"\"\"")

1262+ (FC _ _ end) <- getFC

1263+ return (str, FC f start end)

1254

1264

1255{- | Parses a static modifier

1265{- | Parses a static modifier

1256

1266

@@ -1317,26 +1327,26 @@ data TacticArg = NameTArg -- ^ Names: n1, n2, n3, ... n

1317tactics :: [([String], Maybe TacticArg, SyntaxInfo -> IdrisParser PTactic)]

1327tactics :: [([String], Maybe TacticArg, SyntaxInfo -> IdrisParser PTactic)]

1318tactics =

1328tactics =

1319 [ (["intro"], Nothing, const $ -- FIXME syntax for intro (fresh name)

1329 [ (["intro"], Nothing, const $ -- FIXME syntax for intro (fresh name)

1320− do ns <- sepBy (spaced name) (lchar ','); return $ Intro ns)

1330+ do ns <- sepBy (spaced (fst <$> name)) (lchar ','); return $ Intro ns)

1321 , noArgs ["intros"] Intros

1331 , noArgs ["intros"] Intros

1322 , noArgs ["unfocus"] Unfocus

1332 , noArgs ["unfocus"] Unfocus

1323 , (["refine"], Just ExprTArg, const $

1333 , (["refine"], Just ExprTArg, const $

1324− do n <- spaced fnName

1334+ do n <- spaced (fst <$> fnName)

1325 imps <- many imp

1335 imps <- many imp

1326 return $ Refine n imps)

1336 return $ Refine n imps)

1327 , (["claim"], Nothing, \syn ->

1337 , (["claim"], Nothing, \syn ->

1328− do n <- indentPropHolds gtProp *> name

1338+ do n <- indentPropHolds gtProp *> (fst <$> name)

1329 goal <- indentPropHolds gtProp *> expr syn

1339 goal <- indentPropHolds gtProp *> expr syn

1330 return $ Claim n goal)

1340 return $ Claim n goal)

1331 , (["mrefine"], Just ExprTArg, const $

1341 , (["mrefine"], Just ExprTArg, const $

1332− do n <- spaced fnName

1342+ do n <- spaced (fst <$> fnName)

1333 return $ MatchRefine n)

1343 return $ MatchRefine n)

1334 , expressionTactic ["rewrite"] Rewrite

1344 , expressionTactic ["rewrite"] Rewrite

1335 , expressionTactic ["case"] CaseTac

1345 , expressionTactic ["case"] CaseTac

1336 , expressionTactic ["induction"] Induction

1346 , expressionTactic ["induction"] Induction

1337 , expressionTactic ["equiv"] Equiv

1347 , expressionTactic ["equiv"] Equiv

1338 , (["let"], Nothing, \syn -> -- FIXME syntax for let

1348 , (["let"], Nothing, \syn -> -- FIXME syntax for let

1339− do n <- (indentPropHolds gtProp *> name)

1349+ do n <- (indentPropHolds gtProp *> (fst <$> name))

1340 (do indentPropHolds gtProp *> lchar ':'

1350 (do indentPropHolds gtProp *> lchar ':'

1341 ty <- indentPropHolds gtProp *> expr' syn

1351 ty <- indentPropHolds gtProp *> expr' syn

1342 indentPropHolds gtProp *> lchar '='

1352 indentPropHolds gtProp *> lchar '='

@@ -1349,7 +1359,7 @@ tactics =

1349 return $ LetTac n (desugar syn i t)))

1359 return $ LetTac n (desugar syn i t)))

1350

1360

1351 , (["focus"], Just ExprTArg, const $

1361 , (["focus"], Just ExprTArg, const $

1352− do n <- spaced name

1362+ do n <- spaced (fst <$> name)

1353 return $ Focus n)

1363 return $ Focus n)

1354 , expressionTactic ["exact"] Exact

1364 , expressionTactic ["exact"] Exact

1355 , expressionTactic ["applyTactic"] ApplyTactic

1365 , expressionTactic ["applyTactic"] ApplyTactic

@@ -1365,7 +1375,7 @@ tactics =

1365 , noArgs ["trivial"] Trivial

1375 , noArgs ["trivial"] Trivial

1366 , noArgs ["unify"] DoUnify

1376 , noArgs ["unify"] DoUnify

1367 , (["search"], Nothing, const $

1377 , (["search"], Nothing, const $

1368− do depth <- option 10 natural

1378+ do depth <- option 10 $ fst <$> natural

1369 return (ProofSearch True True (fromInteger depth) Nothing []))

1379 return (ProofSearch True True (fromInteger depth) Nothing []))

1370 , noArgs ["instance"] TCInstance

1380 , noArgs ["instance"] TCInstance

1371 , noArgs ["solve"] Solve

1381 , noArgs ["solve"] Solve

@@ -1381,11 +1391,11 @@ tactics =

1381 , expressionTactic [":t", ":type"] TCheck

1391 , expressionTactic [":t", ":type"] TCheck

1382 , expressionTactic [":search"] TSearch

1392 , expressionTactic [":search"] TSearch

1383 , (["fail"], Just StringLitTArg, const $

1393 , (["fail"], Just StringLitTArg, const $

1384− do msg <- stringLiteral

1394+ do msg <- fst <$> stringLiteral

1385 return $ TFail [Idris.Core.TT.TextPart msg])

1395 return $ TFail [Idris.Core.TT.TextPart msg])

1386 , ([":doc"], Just ExprTArg, const $

1396 , ([":doc"], Just ExprTArg, const $

1387 do whiteSpace

1397 do whiteSpace

1388− doc <- (Right <$> constant) <|> (Left <$> fnName)

1398+ doc <- (Right . fst <$> constant) <|> (Left . fst <$> fnName)

1389 eof

1399 eof

1390 return (TDocStr doc))

1400 return (TDocStr doc))

1391 ]

1401 ]

src/Idris/ParseHelpers.hs+84−35

@@ -67,6 +67,12 @@ instance TokenParsing IdrisParser where

67-- | Generalized monadic parsing constraint type

68type MonadicParsing m = (DeltaParsing m, LookAheadParsing m, TokenParsing m, Monad m)

70+class HasLastTokenSpan m where

71+ getLastTokenSpan :: m (Maybe FC)

72+

73+instance HasLastTokenSpan IdrisParser where

74+ getLastTokenSpan = lastTokenSpan <$> get

75+

70-- | Helper to run Idris inner parser based stateT parsers

76-- | Helper to run Idris inner parser based stateT parsers

71runparser :: StateT st IdrisInnerParser res -> st -> String -> String -> Result res

77runparser :: StateT st IdrisInnerParser res -> st -> String -> String -> Result res

72runparser p i inputname =

78runparser p i inputname =

@@ -183,7 +189,7 @@ docComment = do dc <- pushIndent *> docCommentLine

183 many (satisfy isSpace)

189 many (satisfy isSpace)

184 char '@'

190 char '@'

185 many (satisfy isSpace)

191 many (satisfy isSpace)

186− n <- name

192+ n <- fst <$> name

187 many (satisfy isSpace)

193 many (satisfy isSpace)

188 docs <- many (satisfy (not . isEol))

194 docs <- many (satisfy (not . isEol))

189 eol ; someSpace

195 eol ; someSpace

@@ -194,24 +200,32 @@ whiteSpace :: MonadicParsing m => m ()

194whiteSpace = Tok.whiteSpace

200whiteSpace = Tok.whiteSpace

195

201

196-- | Parses a string literal

202-- | Parses a string literal

197−stringLiteral :: MonadicParsing m => m String

203+stringLiteral :: (MonadicParsing m, HasLastTokenSpan m) => m (String, FC)

198−stringLiteral = Tok.stringLiteral

204+stringLiteral = do str <- Tok.stringLiteral

205+ fc <- getLastTokenSpan

206+ return (str, fromMaybe NoFC fc)

199

207

200−-- | Parses a char literal

208+-- | Parses a char literal

201−charLiteral :: MonadicParsing m => m Char

209+charLiteral :: (MonadicParsing m, HasLastTokenSpan m) => m (Char, FC)

202−charLiteral = Tok.charLiteral

210+charLiteral = do ch <- Tok.charLiteral

211+ fc <- getLastTokenSpan

212+ return (ch, fromMaybe NoFC fc)

203

213

204-- | Parses a natural number

214-- | Parses a natural number

205−natural :: MonadicParsing m => m Integer

215+natural :: (MonadicParsing m, HasLastTokenSpan m) => m (Integer, FC)

206−natural = Tok.natural

216+natural = do n <- Tok.natural

217+ fc <- getLastTokenSpan

218+ return (n, fromMaybe NoFC fc)

207

219

208-- | Parses an integral number

220-- | Parses an integral number

209integer :: MonadicParsing m => m Integer

221integer :: MonadicParsing m => m Integer

210integer = Tok.integer

222integer = Tok.integer

211

223

212-- | Parses a floating point number

224-- | Parses a floating point number

213−float :: MonadicParsing m => m Double

225+float :: (MonadicParsing m, HasLastTokenSpan m) => m (Double, FC)

214−float = Tok.double

226+float = do f <- Tok.double

227+ fc <- getLastTokenSpan

228+ return (f, fromMaybe NoFC fc)

215

229

216{- * Symbols, identifiers, names and operators -}

230{- * Symbols, identifiers, names and operators -}

217

231

@@ -250,6 +264,13 @@ symbol = Tok.symbol

250reserved :: MonadicParsing m => String -> m ()

264reserved :: MonadicParsing m => String -> m ()

251reserved = Tok.reserve idrisStyle

265reserved = Tok.reserve idrisStyle

252

266

267+-- | Parses a reserved identifier, computing its span. Assumes that

268+-- reserved identifiers never contain line breaks.

269+reservedFC :: MonadicParsing m => String -> m FC

270+reservedFC str = do (FC file (l, c) _) <- getFC

271+ Tok.reserve idrisStyle str

272+ return $ FC file (l, c) (l, c + length str)

273+

253-- Taken from Parsec (c) Daan Leijen 1999-2001, (c) Paolo Martini 2007

274-- Taken from Parsec (c) Daan Leijen 1999-2001, (c) Paolo Martini 2007

254-- | Parses a reserved operator

275-- | Parses a reserved operator

255reservedOp :: MonadicParsing m => String -> m ()

276reservedOp :: MonadicParsing m => String -> m ()

@@ -257,37 +278,55 @@ reservedOp name = token $ try $

257 do string name

278 do string name

258 notFollowedBy (operatorLetter) <?> ("end of " ++ show name)

279 notFollowedBy (operatorLetter) <?> ("end of " ++ show name)

259

280

281+reservedOpFC :: MonadicParsing m => String -> m FC

282+reservedOpFC name = token $ try $ do (FC f (l, c) _) <- getFC

283+ string name

284+ notFollowedBy (operatorLetter) <?> ("end of " ++ show name)

285+ return (FC f (l, c) (l, c + length name))

286+

260−-- | Parses an identifier as a token

287+-- | Parses an identifier as a token

261−identifier :: MonadicParsing m => m String

288+identifier :: (MonadicParsing m) => m (String, FC)

289+identifier = try(do (i, fc) <-

290+ token $ do (FC f (l, c) _) <- getFC

262−identifier = try(do i <- token $ Tok.ident idrisStyle

291+ i <- Tok.ident idrisStyle

292+ return (i, FC f (l, c) (l, c + length i))

263 when (i == "_") $ unexpected "wildcard"

293 when (i == "_") $ unexpected "wildcard"

264− return i)

294+ return (i, fc))

265

295

266-- | Parses an identifier with possible namespace as a name

296-- | Parses an identifier with possible namespace as a name

267−iName :: MonadicParsing m => [String] -> m Name

297+iName :: (MonadicParsing m, HasLastTokenSpan m) => [String] -> m (Name, FC)

268−iName bad = maybeWithNS identifier False bad <?> "name"

298+iName bad = do (n, fc) <- maybeWithNS identifier False bad

299+ return (n, fc)

300+ <?> "name"

269

301

270-- | Parses an string possibly prefixed by a namespace

302-- | Parses an string possibly prefixed by a namespace

271−maybeWithNS :: MonadicParsing m => m String -> Bool -> [String] -> m Name

303+maybeWithNS :: (MonadicParsing m, HasLastTokenSpan m) => m (String, FC) -> Bool -> [String] -> m (Name, FC)

272maybeWithNS parser ascend bad = do

304maybeWithNS parser ascend bad = do

305+ fc <- getFC

273− i <- option "" (lookAhead identifier)

306+ i <- option "" (lookAhead (fst <$> identifier))

274 when (i `elem` bad) $ unexpected "reserved identifier"

307 when (i `elem` bad) $ unexpected "reserved identifier"

275 let transf = if ascend then id else reverse

308 let transf = if ascend then id else reverse

276− (x, xs) <- choice (transf (parserNoNS parser : parsersNS parser i))

309+ (x, xs, fc) <- choice (transf (parserNoNS parser : parsersNS parser i))

277− return $ mkName (x, xs)

310+ return (mkName (x, xs), fc)

278− where parserNoNS :: MonadicParsing m => m String -> m (String, String)

311+ where parserNoNS :: MonadicParsing m => m (String, FC) -> m (String, String, FC)

279− parserNoNS parser = do x <- parser; return (x, "")

312+ parserNoNS parser = do startFC <- getFC

313+ (x, nameFC) <- parser

314+ return (x, "", spanFC startFC nameFC)

280− parserNS :: MonadicParsing m => m String -> String -> m (String, String)

315+ parserNS :: MonadicParsing m => m (String, FC) -> String -> m (String, String, FC)

281− parserNS parser ns = do xs <- string ns; lchar '.'; x <- parser; return (x, xs)

316+ parserNS parser ns = do startFC <- getFC

317+ xs <- string ns

318+ lchar '.'; (x, nameFC) <- parser

319+ return (x, xs, spanFC startFC nameFC)

282− parsersNS :: MonadicParsing m => m String -> String -> [m (String, String)]

320+ parsersNS :: MonadicParsing m => m (String, FC) -> String -> [m (String, String, FC)]

283− parsersNS parser i = [try (parserNS parser ns) | ns <- (initsEndAt (=='.') i)]

321+ parsersNS parser i = [try (parserNS parser ns) | ns <- (initsEndAt (=='.') i)]

284

322

285-- | Parses a name

323-- | Parses a name

286−name :: IdrisParser Name

324+name :: IdrisParser (Name, FC)

287name = (<?> "name") $ do

325name = (<?> "name") $ do

288 keywords <- syntax_keywords <$> get

326 keywords <- syntax_keywords <$> get

289 aliases <- module_aliases <$> get

327 aliases <- module_aliases <$> get

290− unalias aliases <$> iName keywords

328+ (n, fc) <- iName keywords

329+ return (unalias aliases n, fc)

291 where

330 where

292 unalias :: M.Map [T.Text] [T.Text] -> Name -> Name

331 unalias :: M.Map [T.Text] [T.Text] -> Name -> Name

293 unalias aliases (NS n ns) | Just ns' <- M.lookup ns aliases = NS n ns'

332 unalias aliases (NS n ns) | Just ns' <- M.lookup ns aliases = NS n ns'

@@ -334,6 +373,15 @@ operator = do op <- token . some $ operatorLetter

334 fail $ op ++ " is not a valid operator"

373 fail $ op ++ " is not a valid operator"

335 return op

374 return op

336

375

376+-- | Parses an operator

377+operatorFC :: MonadicParsing m => m (String, FC)

378+operatorFC = do (op, fc) <- token $ do (FC f (l, c) _) <- getFC

379+ op <- some operatorLetter

380+ return (op, FC f (l, c) (l, c + length op))

381+ when (op `elem` (invalidOperators ++ commentMarkers)) $

382+ fail $ op ++ " is not a valid operator"

383+ return (op, fc)

384+

337{- * Position helpers -}

385{- * Position helpers -}

338{- | Get filename from position (returns "(interactive)" when no source file is given) -}

386{- | Get filename from position (returns "(interactive)" when no source file is given) -}

339fileName :: Delta -> String

387fileName :: Delta -> String

@@ -360,11 +408,12 @@ getFC = do s <- position

360 -- Issue #1594 on the Issue Tracker.

408 -- Issue #1594 on the Issue Tracker.

361 -- https://github.com/idris-lang/Idris-dev/issues/1594

409 -- https://github.com/idris-lang/Idris-dev/issues/1594

362

410

411+

363{-* Syntax helpers-}

412{-* Syntax helpers-}

364-- | Bind constraints to term

413-- | Bind constraints to term

365−bindList :: (Name -> PTerm -> PTerm -> PTerm) -> [(Name, PTerm)] -> PTerm -> PTerm

414+bindList :: (Name -> FC -> PTerm -> PTerm -> PTerm) -> [(Name, FC, PTerm)] -> PTerm -> PTerm

366−bindList b [] sc = sc

415+bindList b [] sc = sc

367−bindList b ((n, t):bs) sc = b n t (bindList b bs sc)

416+bindList b ((n, fc, t):bs) sc = b n fc t (bindList b bs sc)

368

417

369{- * Layout helpers -}

418{- * Layout helpers -}

370

419

@@ -584,9 +633,9 @@ collect (c@(PClauses _ o _ _) : ds)

584collect (PParams f ns ps : ds) = PParams f ns (collect ps) : collect ds

633collect (PParams f ns ps : ds) = PParams f ns (collect ps) : collect ds

585collect (PMutual f ms : ds) = PMutual f (collect ms) : collect ds

634collect (PMutual f ms : ds) = PMutual f (collect ms) : collect ds

586collect (PNamespace ns ps : ds) = PNamespace ns (collect ps) : collect ds

635collect (PNamespace ns ps : ds) = PNamespace ns (collect ps) : collect ds

587−collect (PClass doc f s cs n ps pdocs fds ds cn cd : ds')

636+collect (PClass doc f s cs n nfc ps pdocs fds ds cn cd : ds')

588− = PClass doc f s cs n ps pdocs fds (collect ds) cn cd : collect ds'

637+ = PClass doc f s cs n nfc ps pdocs fds (collect ds) cn cd : collect ds'

589−collect (PInstance doc argDocs f s cs n ps t en ds : ds')

638+collect (PInstance doc argDocs f s cs n nfc ps t en ds : ds')

590− = PInstance doc argDocs f s cs n ps t en (collect ds) : collect ds'

639+ = PInstance doc argDocs f s cs n nfc ps t en (collect ds) : collect ds'

591collect (d : ds) = d : collect ds

640collect (d : ds) = d : collect ds

592collect [] = []

641collect [] = []

src/Idris/ParseOps.hs+19−12

@@ -29,6 +29,8 @@ import qualified Data.HashSet as HS

29import qualified Data.Text as T

30import qualified Data.ByteString.UTF8 as UTF8

32+import Debug.Trace

33+

32-- | Creates table for fixity declarations to build expression parser

34-- | Creates table for fixity declarations to build expression parser

33-- using pre-build and user-defined operator/fixity declarations

35-- using pre-build and user-defined operator/fixity declarations

34table :: [FixDecl] -> OperatorTable IdrisParser PTerm

36table :: [FixDecl] -> OperatorTable IdrisParser PTerm

@@ -45,7 +47,7 @@ table fixes

45 flatten t = t

47 flatten t = t

48−-- | Calculates table for fixtiy declarations

50+-- | Calculates table for fixity declarations

49toTable :: [FixDecl] -> OperatorTable IdrisParser PTerm

51toTable :: [FixDecl] -> OperatorTable IdrisParser PTerm

50toTable fs = map (map toBin)

52toTable fs = map (map toBin)

51 (groupBy (\ (Fix x _) (Fix y _) -> prec x == prec y) fs)

53 (groupBy (\ (Fix x _) (Fix y _) -> prec x == prec y) fs)

@@ -59,9 +61,8 @@ toTable fs = map (map toBin)

60-- | Binary operator

62-- | Binary operator

61binary :: String -> (FC -> PTerm -> PTerm -> PTerm) -> Assoc -> Operator IdrisParser PTerm

63binary :: String -> (FC -> PTerm -> PTerm -> PTerm) -> Assoc -> Operator IdrisParser PTerm

62−binary name f = Infix (do fc <- getFC

63− indentPropHolds gtProp

64+binary name f = Infix (do indentPropHolds gtProp

64− reservedOp name

65+ fc <- reservedOpFC name

65 indentPropHolds gtProp

66 indentPropHolds gtProp

66 return (f fc))

67 return (f fc))

@@ -75,10 +76,9 @@ prefix name f = Prefix (do reservedOp name

75-- | Backtick operator

76-- | Backtick operator

76backtick :: Operator IdrisParser PTerm

77backtick :: Operator IdrisParser PTerm

77backtick = Infix (do indentPropHolds gtProp

78backtick = Infix (do indentPropHolds gtProp

78− lchar '`'; n <- fnName

79+ lchar '`'; (n, fc) <- fnName

79 lchar '`'

80 lchar '`'

80 indentPropHolds gtProp

81 indentPropHolds gtProp

81− fc <- getFC

82 return (\x y -> PApp fc (PRef fc n) [pexp x, pexp y])) AssocNone

84-- | Operator without fixity (throws an error)

@@ -86,7 +86,7 @@ nofixityoperator :: Operator IdrisParser PTerm

86nofixityoperator = Infix (do indentPropHolds gtProp

87 op <- try operator

88 unexpected $ "Operator without known fixity: " ++ op) AssocNone

89−

89+

91{- | Parses an operator in function position i.e. enclosed by `()', with an

92 optional namespace

@@ -99,9 +99,15 @@ nofixityoperator = Infix (do indentPropHolds gtProp

99@

100

101-}

102−operatorFront :: IdrisParser Name

102+operatorFront :: IdrisParser (Name, FC)

103+operatorFront = try (do (FC f (l, c) _) <- getFC

103−operatorFront = try ((lchar '(' *> reservedOp "=" <* lchar ')') >> (return eqTy))

104+ op <- lchar '(' *> reservedOp "=" <* lchar ')'

105+ return (eqTy, FC f (l, c) (l, c+3)))

106+ <|> maybeWithNS (do (FC f (l, c) _) <- getFC

104− <|> maybeWithNS (lchar '(' *> operator <* lchar ')') False []

107+ op <- lchar '(' *> operator

108+ (FC _ _ (l', c')) <- getFC

109+ lchar ')'

110+ return (op, (FC f (l, c) (l', c' + 1)))) False []

105

111

106{- | Parses a function (either normal name or operator)

112{- | Parses a function (either normal name or operator)

107

113

@@ -109,7 +115,7 @@ operatorFront = try ((lchar '(' *> reservedOp "=" <* lchar ')') >> (return eqTy

109 FnName ::= Name | OperatorFront;

115 FnName ::= Name | OperatorFront;

110@

116@

111-}

117-}

112−fnName :: IdrisParser Name

118+fnName :: IdrisParser (Name, FC)

113fnName = try operatorFront <|> name <?> "function name"

119fnName = try operatorFront <|> name <?> "function name"

114

120

115{- | Parses a fixity declaration

121{- | Parses a fixity declaration

@@ -121,7 +127,8 @@ Fixity ::=

121-}

127-}

122fixity :: IdrisParser PDecl

128fixity :: IdrisParser PDecl

123fixity = do pushIndent

129fixity = do pushIndent

130+ f <- fixityType; i <- fst <$> natural;

124− f <- fixityType; i <- natural; ops <- sepBy1 operator (lchar ',')

131+ ops <- sepBy1 operator (lchar ',')

125 terminator

132 terminator

126 let prec = fromInteger i

133 let prec = fromInteger i

127 istate <- get

134 istate <- get

src/Idris/Parser.hs+92−78

@@ -96,7 +96,7 @@ moduleHeader :: IdrisParser (Maybe (Docstring ()), [String])

96moduleHeader = try (do docs <- optional docComment

97 noArgs docs

98 reserved "module"

99− i <- identifier

99+ i <- fst <$> identifier

100 option ';' (lchar ';')

101 return (fmap fst docs, moduleName i))

102 <|> try (do lchar '%'; reserved "unqualified"

@@ -118,8 +118,8 @@ import_ :: IdrisParser (Bool, String, Maybe String, FC)

118import_ = do fc <- getFC

119 reserved "import"

120 reexport <- option False (do reserved "public"; return True)

121− id <- identifier

121+ id <- fst <$> identifier

122− newName <- optional (reserved "as" *> identifier)

122+ newName <- optional (reserved "as" *> (fst <$> identifier))

123 option ';' (lchar ';')

124 return (reexport, toPath id, toPath <$> newName, fc)

125 <?> "import statement"

@@ -310,22 +310,22 @@ syntaxRule syn

310 return $ PRef fc n'

311 fixBind rens (PPatvar fc n) | Just n' <- lookup n rens =

312 return $ PPatvar fc n'

313− fixBind rens (PLam fc n ty body)

313+ fixBind rens (PLam fc n nfc ty body)

314− | n `elem` userNames = liftM2 (PLam fc n) (fixBind rens ty) (fixBind rens body)

314+ | n `elem` userNames = liftM2 (PLam fc n nfc) (fixBind rens ty) (fixBind rens body)

315 | otherwise =

316 do ty' <- fixBind rens ty

317 n' <- gensym n

318 body' <- fixBind ((n,n'):rens) body

319− return $ PLam fc n' ty' body'

319+ return $ PLam fc n' nfc ty' body'

320− fixBind rens (PPi plic n argTy body)

320+ fixBind rens (PPi plic n nfc argTy body)

321− | n `elem` userNames = liftM2 (PPi plic n) (fixBind rens argTy) (fixBind rens body)

321+ | n `elem` userNames = liftM2 (PPi plic n nfc) (fixBind rens argTy) (fixBind rens body)

322 | otherwise =

323 do ty' <- fixBind rens argTy

324 n' <- gensym n

325 body' <- fixBind ((n,n'):rens) body

326− return $ (PPi plic n' ty' body')

326+ return $ (PPi plic n' nfc ty' body')

327− fixBind rens (PLet fc n ty val body)

327+ fixBind rens (PLet fc n nfc ty val body)

328− | n `elem` userNames = liftM3 (PLet fc n)

328+ | n `elem` userNames = liftM3 (PLet fc n nfc)

329 (fixBind rens ty)

330 (fixBind rens val)

331 (fixBind rens body)

@@ -334,7 +334,7 @@ syntaxRule syn

334 val' <- fixBind rens val

335 n' <- gensym n

336 body' <- fixBind ((n,n'):rens) body

337− return $ (PLet fc n' ty' val' body')

337+ return $ PLet fc n' nfc ty' val' body'

338 fixBind rens (PMatchApp fc n) | Just n' <- lookup n rens =

339 return $ PMatchApp fc n'

340 fixBind rens x = descendM (fixBind rens) x

@@ -356,13 +356,13 @@ SyntaxSym ::= '[' Name_t ']'

356@

357 -}

358syntaxSym :: IdrisParser SSymbol

359−syntaxSym = try (do lchar '['; n <- name; lchar ']'

359+syntaxSym = try (do lchar '['; n <- fst <$> name; lchar ']'

360 return (Expr n))

361− <|> try (do lchar '{'; n <- name; lchar '}'

361+ <|> try (do lchar '{'; n <- fst <$> name; lchar '}'

362 return (Binding n))

363− <|> do n <- iName []

363+ <|> do n <- fst <$> iName []

364 return (Keyword n)

365− <|> do sym <- stringLiteral

365+ <|> do sym <- fmap fst stringLiteral

366 return (Symbol sym)

367 <?> "syntax symbol"

368

@@ -392,7 +392,7 @@ fnDecl syn = try (do notEndBlock

392-}

393fnDecl' :: SyntaxInfo -> IdrisParser PDecl

394fnDecl' syn = checkFixity $

395− do (doc, argDocs, fc, opts', n, acc) <- try (do

395+ do (doc, argDocs, fc, opts', n, nfc, acc) <- try (do

396 pushIndent

397 (doc, argDocs) <- docstring syn

398 ist <- get

@@ -402,15 +402,15 @@ fnDecl' syn = checkFixity $

402 opts <- fnOpts initOpts

403 acc <- optional accessibility

404 opts' <- fnOpts opts

405− n_in <- fnName

405+ (n_in, nfc) <- fnName

406 let n = expandNS syn n_in

407 fc <- getFC

408 lchar ':'

409− return (doc, argDocs, fc, opts', n, acc))

409+ return (doc, argDocs, fc, opts', n, nfc, acc))

410 ty <- typeExpr (allowImp syn)

411 terminator

412 addAcc n acc

413− return (PTy doc argDocs syn fc opts' n ty)

413+ return (PTy doc argDocs syn fc opts' n nfc ty)

414 <|> postulate syn

415 <|> caf syn

416 <|> pattern syn

@@ -423,7 +423,7 @@ fnDecl' syn = checkFixity $

423 unless fOk . fail $

424 "Missing fixity declaration for " ++ show n

425 return decl

426− getName (PTy _ _ _ _ _ n _) = Just n

426+ getName (PTy _ _ _ _ _ n _ _) = Just n

427 getName _ = Nothing

428 fixityOK (NS n _) = fixityOK n

429 fixityOK (UN n) | all (flip elem opChars) (str n) =

@@ -437,6 +437,7 @@ fnDecl' syn = checkFixity $

437@

438FnOpts ::= 'total'

439 | 'partial'

440+ | 'covering'

440 | 'implicit'

441 | 'implicit'

441 | '%' 'no_implicit'

442 | '%' 'no_implicit'

442 | '%' 'assert_total'

443 | '%' 'assert_total'

@@ -466,7 +467,7 @@ fnOpts opts

466 = do reserved "total"; fnOpts (TotalFn : opts)

467 = do reserved "total"; fnOpts (TotalFn : opts)

467 <|> do reserved "partial"; fnOpts (PartialFn : (opts \\ [TotalFn]))

468 <|> do reserved "partial"; fnOpts (PartialFn : (opts \\ [TotalFn]))

468 <|> do reserved "covering"; fnOpts (CoveringFn : (opts \\ [TotalFn]))

469 <|> do reserved "covering"; fnOpts (CoveringFn : (opts \\ [TotalFn]))

469− <|> do try (lchar '%' *> reserved "export"); c <- stringLiteral;

470+ <|> do try (lchar '%' *> reserved "export"); c <- fmap fst stringLiteral;

470 fnOpts (CExport c : opts)

471 fnOpts (CExport c : opts)

471 <|> do try (lchar '%' *> reserved "no_implicit");

472 <|> do try (lchar '%' *> reserved "no_implicit");

472 fnOpts (NoImplicit : opts)

473 fnOpts (NoImplicit : opts)

@@ -489,8 +490,8 @@ fnOpts opts

489 <|> return opts

490 <|> return opts

490 <?> "function modifier"

491 <?> "function modifier"

491 where nameTimes :: IdrisParser (Name, Maybe Int)

492 where nameTimes :: IdrisParser (Name, Maybe Int)

492− nameTimes = do n <- fnName

493+ nameTimes = do n <- fst <$> fnName

493− t <- option Nothing (do reds <- natural

494+ t <- option Nothing (do reds <- fmap fst natural

494 return (Just (fromInteger reds)))

495 return (Just (fromInteger reds)))

495 return (n, t)

496 return (n, t)

496

497

@@ -515,7 +516,7 @@ postulate syn = do (doc, ext)

515 opts <- fnOpts initOpts

516 opts <- fnOpts initOpts

516 acc <- optional accessibility

517 acc <- optional accessibility

517 opts' <- fnOpts opts

518 opts' <- fnOpts opts

518− n_in <- fnName

519+ n_in <- fst <$> fnName

519 let n = expandNS syn n_in

520 let n = expandNS syn n_in

520 lchar ':'

521 lchar ':'

521 ty <- typeExpr (allowImp syn)

522 ty <- typeExpr (allowImp syn)

@@ -555,12 +556,13 @@ Params ::=

555params :: SyntaxInfo -> IdrisParser [PDecl]

556params :: SyntaxInfo -> IdrisParser [PDecl]

556params syn =

557params syn =

557 do reserved "parameters"; lchar '('; ns <- typeDeclList syn; lchar ')'

558 do reserved "parameters"; lchar '('; ns <- typeDeclList syn; lchar ')'

559+ let ns' = [(n, ty) | (n, _, ty) <- ns]

558 openBlock

560 openBlock

559 let pvars = syn_params syn

561 let pvars = syn_params syn

560− ds <- many (decl syn { syn_params = pvars ++ ns })

562+ ds <- many (decl syn { syn_params = pvars ++ ns' })

561 closeBlock

563 closeBlock

562 fc <- getFC

564 fc <- getFC

563− return [PParams fc ns (concat ds)]

565+ return [PParams fc ns' (concat ds)]

564 <?> "parameters declaration"

566 <?> "parameters declaration"

565

567

566{- | Parses a mutual declaration (for mutually recursive functions)

568{- | Parses a mutual declaration (for mutually recursive functions)

@@ -592,7 +594,7 @@ Namespace ::=

592-}

594-}

593namespace :: SyntaxInfo -> IdrisParser [PDecl]

595namespace :: SyntaxInfo -> IdrisParser [PDecl]

594namespace syn =

596namespace syn =

595− do reserved "namespace"; n <- identifier;

597+ do reserved "namespace"; n <- fst <$> identifier

596 openBlock

598 openBlock

597 ds <- some (decl syn { syn_namespace = n : syn_namespace syn })

599 ds <- some (decl syn { syn_namespace = n : syn_namespace syn })

598 closeBlock

600 closeBlock

@@ -628,7 +630,7 @@ ClassBlock ::=

628 ;

630 ;

629@

631@

630-}

632-}

631−classBlock :: SyntaxInfo -> IdrisParser (Maybe Name, Docstring (Either Err PTerm), [PDecl])

633+classBlock :: SyntaxInfo -> IdrisParser (Maybe (Name, FC), Docstring (Either Err PTerm), [PDecl])

632classBlock syn = do reserved "where"

634classBlock syn = do reserved "where"

633 openBlock

635 openBlock

634 (cn, cd) <- option (Nothing, emptyDocstring) $

636 (cn, cd) <- option (Nothing, emptyDocstring) $

@@ -644,7 +646,7 @@ classBlock syn = do reserved "where"

644 <?> "class block"

646 <?> "class block"

645

647

646 where

648 where

647− constructor :: IdrisParser Name

649+ constructor :: IdrisParser (Name, FC)

648 constructor = reserved "constructor" *> fnName

650 constructor = reserved "constructor" *> fnName

649

651

650 annotate :: SyntaxInfo -> IState -> Docstring () -> Docstring (Either Err PTerm)

652 annotate :: SyntaxInfo -> IState -> Docstring () -> Docstring (Either Err PTerm)

@@ -673,23 +675,25 @@ class_ syn = do (doc, argDocs, acc)

673 return (doc, argDocs, acc))

675 return (doc, argDocs, acc))

674 fc <- getFC

676 fc <- getFC

675 cons <- constraintList syn

677 cons <- constraintList syn

678+ let cons' = [(c, ty) | (c, _, ty) <- cons]

676− n_in <- fnName

679+ (n_in, nfc) <- fnName

677 let n = expandNS syn n_in

680 let n = expandNS syn n_in

678 cs <- many carg

681 cs <- many carg

679− fds <- option (map fst cs) fundeps

682+ fds <- option [(cn, NoFC) | (cn, _, _) <- cs] fundeps

680 (cn, cd, ds) <- option (Nothing, fst noDocs, []) (classBlock syn)

683 (cn, cd, ds) <- option (Nothing, fst noDocs, []) (classBlock syn)

681 accData acc n (concatMap declared ds)

684 accData acc n (concatMap declared ds)

682− return [PClass doc syn fc cons n cs argDocs fds ds cn cd]

685+ return [PClass doc syn fc cons' n nfc cs argDocs fds ds cn cd]

683 <?> "type-class declaration"

686 <?> "type-class declaration"

684 where

687 where

685− fundeps :: IdrisParser [Name]

688+ fundeps :: IdrisParser [(Name, FC)]

686 fundeps = do lchar '|'; sepBy name (lchar ',')

689 fundeps = do lchar '|'; sepBy name (lchar ',')

687

690

688− carg :: IdrisParser (Name, PTerm)

691+ carg :: IdrisParser (Name, FC, PTerm)

689− carg = do lchar '('; i <- name; lchar ':'; ty <- expr syn; lchar ')'

692+ carg = do lchar '('; (i, ifc) <- name; lchar ':'; ty <- expr syn; lchar ')'

690− return (i, ty)

693+ return (i, ifc, ty)

691− <|> do i <- name;

694+ <|> do (i, ifc) <- name

695+ fc <- getFC

692− return (i, PType)

696+ return (i, ifc, PType fc)

693

697

694{- | Parses a type class instance declaration

698{- | Parses a type class instance declaration

695

699

@@ -709,15 +713,16 @@ instance_ syn = do (doc, argDocs)

709 fc <- getFC

713 fc <- getFC

710 en <- optional instanceName

714 en <- optional instanceName

711 cs <- constraintList syn

715 cs <- constraintList syn

716+ let cs' = [(c, ty) | (c, _, ty) <- cs]

712− cn <- fnName

717+ (cn, cnfc) <- fnName

713 args <- many (simpleExpr syn)

718 args <- many (simpleExpr syn)

714− let sc = PApp fc (PRef fc cn) (map pexp args)

719+ let sc = PApp fc (PRef cnfc cn) (map pexp args)

715 let t = bindList (PPi constraint) cs sc

720 let t = bindList (PPi constraint) cs sc

716 ds <- option [] (instanceBlock syn)

721 ds <- option [] (instanceBlock syn)

717− return [PInstance doc argDocs syn fc cs cn args t en ds]

722+ return [PInstance doc argDocs syn fc cs' cn cnfc args t en ds]

718 <?> "instance declaration"

723 <?> "instance declaration"

719 where instanceName :: IdrisParser Name

724 where instanceName :: IdrisParser Name

720− instanceName = do lchar '['; n_in <- fnName; lchar ']'

725+ instanceName = do lchar '['; n_in <- fst <$> fnName; lchar ']'

721 let n = expandNS syn n_in

726 let n = expandNS syn n_in

722 return n

727 return n

723 <?> "instance name"

728 <?> "instance name"

@@ -761,7 +766,7 @@ NameList ::=

761usingDeclList :: SyntaxInfo -> IdrisParser [Using]

766usingDeclList :: SyntaxInfo -> IdrisParser [Using]

762usingDeclList syn

767usingDeclList syn

763 = try (sepBy1 (usingDecl syn) (lchar ','))

768 = try (sepBy1 (usingDecl syn) (lchar ','))

764− <|> do ns <- sepBy1 name (lchar ',')

769+ <|> do ns <- sepBy1 (fst <$> name) (lchar ',')

765 lchar ':'

770 lchar ':'

766 t <- typeExpr (disallowImp syn)

771 t <- typeExpr (disallowImp syn)

767 return (map (\x -> UImplicit x t) ns)

772 return (map (\x -> UImplicit x t) ns)

@@ -777,12 +782,12 @@ UsingDecl ::=

777@

782@

778-}

783-}

779usingDecl :: SyntaxInfo -> IdrisParser Using

784usingDecl :: SyntaxInfo -> IdrisParser Using

780−usingDecl syn = try (do x <- fnName

785+usingDecl syn = try (do x <- fst <$> fnName

781 lchar ':'

786 lchar ':'

782 t <- typeExpr (disallowImp syn)

787 t <- typeExpr (disallowImp syn)

783 return (UImplicit x t))

788 return (UImplicit x t))

784− <|> do c <- fnName

789+ <|> do c <- fst <$> fnName

785− xs <- some fnName

790+ xs <- some (fst <$> fnName)

786 return (UConstraint c xs)

791 return (UConstraint c xs)

787 <?> "using declaration"

792 <?> "using declaration"

788

793

@@ -806,7 +811,7 @@ CAF ::= 'let' FnName '=' Expr Terminator;

806-}

811-}

807caf :: SyntaxInfo -> IdrisParser PDecl

812caf :: SyntaxInfo -> IdrisParser PDecl

808caf syn = do reserved "let"

813caf syn = do reserved "let"

809− n_in <- fnName; let n = expandNS syn n_in

814+ n_in <- fst <$> fnName; let n = expandNS syn n_in

810 lchar '='

815 lchar '='

811 t <- expr syn

816 t <- expr syn

812 terminator

817 terminator

@@ -842,7 +847,7 @@ rhs :: SyntaxInfo -> Name -> IdrisParser PTerm

842rhs syn n = do lchar '='; expr syn

847rhs syn n = do lchar '='; expr syn

843 <|> do symbol "?=";

848 <|> do symbol "?=";

844 fc <- getFC

849 fc <- getFC

845− name <- option n' (do symbol "{"; n <- fnName; symbol "}";

850+ name <- option n' (do symbol "{"; n <- fst <$> fnName; symbol "}";

846 return n)

851 return n)

847 r <- expr syn

852 r <- expr syn

848 return (addLet fc name r)

853 return (addLet fc name r)

@@ -856,10 +861,10 @@ rhs syn n = do lchar '='; expr syn

856 n' :: Name

861 n' :: Name

857 n' = mkN n

862 n' = mkN n

858 addLet :: FC -> Name -> PTerm -> PTerm

863 addLet :: FC -> Name -> PTerm -> PTerm

859− addLet fc nm (PLet fc' n ty val r) = PLet fc' n ty val (addLet fc nm r)

864+ addLet fc nm (PLet fc' n nfc ty val r) = PLet fc' n nfc ty val (addLet fc nm r)

860 addLet fc nm (PCase fc' t cs) = PCase fc' t (map addLetC cs)

865 addLet fc nm (PCase fc' t cs) = PCase fc' t (map addLetC cs)

861 where addLetC (l, r) = (l, addLet fc nm r)

866 where addLetC (l, r) = (l, addLet fc nm r)

862− addLet fc nm r = (PLet fc (sUN "value") Placeholder r (PMetavar nm))

867+ addLet fc nm r = (PLet fc (sUN "value") NoFC Placeholder r (PMetavar nm))

863

868

864{- |Parses a function clause

869{- |Parses a function clause

865

870

@@ -916,7 +921,7 @@ clause syn

916 symbol "<=="

921 symbol "<=="

917 return ty)

922 return ty)

918 fc <- getFC

923 fc <- getFC

919− n_in <- fnName; let n = expandNS syn n_in

924+ n_in <- fst <$> fnName; let n = expandNS syn n_in

920 r <- rhs syn n

925 r <- rhs syn n

921 ist <- get

926 ist <- get

922 let ctxt = tt_ctxt ist

927 let ctxt = tt_ctxt ist

@@ -926,20 +931,20 @@ clause syn

926 return x,

931 return x,

927 do terminator

932 do terminator

928 return ([], [])]

933 return ([], [])]

929− let capp = PLet fc (sMN 0 "match")

934+ let capp = PLet fc (sMN 0 "match") NoFC

930 ty

935 ty

931 (PMatchApp fc n)

936 (PMatchApp fc n)

932 (PRef fc (sMN 0 "match"))

937 (PRef fc (sMN 0 "match"))

933 ist <- get

938 ist <- get

934 put (ist { lastParse = Just n })

939 put (ist { lastParse = Just n })

935 return $ PClause fc n capp [] r wheres

940 return $ PClause fc n capp [] r wheres

936− <|> do (l, op) <- try (do

941+ <|> do (l, op, nfc) <- try (do

937 pushIndent

942 pushIndent

938 l <- argExpr syn

943 l <- argExpr syn

939− op <- operator

944+ (op, nfc) <- operatorFC

940 when (op == "=" || op == "?=" ) $

945 when (op == "=" || op == "?=" ) $

941 fail "infix clause definition with \"=\" and \"?=\" not supported "

946 fail "infix clause definition with \"=\" and \"?=\" not supported "

942− return (l, op))

947+ return (l, op, nfc))

943 let n = expandNS syn (sUN op)

948 let n = expandNS syn (sUN op)

944 r <- argExpr syn

949 r <- argExpr syn

945 fc <- getFC

950 fc <- getFC

@@ -952,7 +957,7 @@ clause syn

952 do terminator

957 do terminator

953 return ([], [])]

958 return ([], [])]

954 ist <- get

959 ist <- get

955− let capp = PApp fc (PRef fc n) [pexp l, pexp r]

960+ let capp = PApp fc (PRef nfc n) [pexp l, pexp r]

956 put (ist { lastParse = Just n })

961 put (ist { lastParse = Just n })

957 return $ PClause fc n capp wargs rs wheres) <|> (do

962 return $ PClause fc n capp wargs rs wheres) <|> (do

958 popIndent

963 popIndent

@@ -968,13 +973,13 @@ clause syn

968 put (ist { lastParse = Just n })

973 put (ist { lastParse = Just n })

969 return $ PWith fc n capp wargs wval pn withs)

974 return $ PWith fc n capp wargs wval pn withs)

970 <|> do pushIndent

975 <|> do pushIndent

971− n_in <- fnName; let n = expandNS syn n_in

976+ (n_in, nfc) <- fnName; let n = expandNS syn n_in

972 cargs <- many (constraintArg syn)

977 cargs <- many (constraintArg syn)

973 fc <- getFC

978 fc <- getFC

974 args <- many (try (implicitArg (syn { inPattern = True } ))

979 args <- many (try (implicitArg (syn { inPattern = True } ))

975 <|> (fmap pexp (argExpr syn)))

980 <|> (fmap pexp (argExpr syn)))

976 wargs <- many (wExpr syn)

981 wargs <- many (wExpr syn)

977− let capp = PApp fc (PRef fc n)

982+ let capp = PApp fc (PRef nfc n)

978 (cargs ++ args)

983 (cargs ++ args)

979 (do r <- rhs syn n

984 (do r <- rhs syn n

980 ist <- get

985 ist <- get

@@ -1055,7 +1060,8 @@ Codegen ::= 'C'

1055@

1060@

1056-}

1061-}

1057codegen_ :: IdrisParser Codegen

1062codegen_ :: IdrisParser Codegen

1063+codegen_ = do n <- fst <$> identifier

1058−codegen_ = do n <- identifier; return (Via (map toLower n))

1064+ return (Via (map toLower n))

1059 <|> do reserved "Bytecode"; return Bytecode

1065 <|> do reserved "Bytecode"; return Bytecode

1060 <?> "code generation language"

1066 <?> "code generation language"

1061

1067

@@ -1090,17 +1096,23 @@ Directive' ::= 'lib' CodeGen String_t

1090@

1096@

1091-}

1097-}

1092directive :: SyntaxInfo -> IdrisParser [PDecl]

1098directive :: SyntaxInfo -> IdrisParser [PDecl]

1093−directive syn = do try (lchar '%' *> reserved "lib"); cgn <- codegen_; lib <- stringLiteral;

1099+directive syn = do try (lchar '%' *> reserved "lib")

1100+ cgn <- codegen_

1101+ lib <- fmap fst stringLiteral

1094 return [PDirective (DLib cgn lib)]

1102 return [PDirective (DLib cgn lib)]

1103+ <|> do try (lchar '%' *> reserved "link")

1095− <|> do try (lchar '%' *> reserved "link"); cgn <- codegen_; obj <- stringLiteral;

1104+ cgn <- codegen_; obj <- fst <$> stringLiteral

1096 return [PDirective (DLink cgn obj)]

1105 return [PDirective (DLink cgn obj)]

1106+ <|> do try (lchar '%' *> reserved "flag")

1097− <|> do try (lchar '%' *> reserved "flag"); cgn <- codegen_; flag <- stringLiteral

1107+ cgn <- codegen_; flag <- fst <$> stringLiteral

1098 return [PDirective (DFlag cgn flag)]

1108 return [PDirective (DFlag cgn flag)]

1099− <|> do try (lchar '%' *> reserved "include"); cgn <- codegen_; hdr <- stringLiteral;

1109+ <|> do try (lchar '%' *> reserved "include")

1110+ cgn <- codegen_

1111+ hdr <- fst <$> stringLiteral

1100 return [PDirective (DInclude cgn hdr)]

1112 return [PDirective (DInclude cgn hdr)]

1101− <|> do try (lchar '%' *> reserved "hide"); n <- fnName

1113+ <|> do try (lchar '%' *> reserved "hide"); n <- fst <$> fnName

1102 return [PDirective (DHide n)]

1114 return [PDirective (DHide n)]

1103− <|> do try (lchar '%' *> reserved "freeze"); n <- iName []

1115+ <|> do try (lchar '%' *> reserved "freeze"); n <- fst <$> iName []

1104 return [PDirective (DFreeze n)]

1116 return [PDirective (DFreeze n)]

1105 <|> do try (lchar '%' *> reserved "access"); acc <- accessibility

1117 <|> do try (lchar '%' *> reserved "access"); acc <- accessibility

1106 return [PDirective (DAccess acc)]

1118 return [PDirective (DAccess acc)]

@@ -1108,25 +1120,27 @@ directive syn = do try (lchar '%' *> reserved "lib"); cgn <- codegen_; lib <- st

1108 i <- get

1120 i <- get

1109 put (i { default_total = tot } )

1121 put (i { default_total = tot } )

1110 return [PDirective (DDefault tot)]

1122 return [PDirective (DDefault tot)]

1111− <|> do try (lchar '%' *> reserved "logging"); i <- natural;

1123+ <|> do try (lchar '%' *> reserved "logging")

1124+ i <- fst <$> natural

1112 return [PDirective (DLogging i)]

1125 return [PDirective (DLogging i)]

1113− <|> do try (lchar '%' *> reserved "dynamic"); libs <- sepBy1 stringLiteral (lchar ',');

1126+ <|> do try (lchar '%' *> reserved "dynamic")

1127+ libs <- sepBy1 (fmap fst stringLiteral) (lchar ',')

1114 return [PDirective (DDynamicLibs libs)]

1128 return [PDirective (DDynamicLibs libs)]

1115 <|> do try (lchar '%' *> reserved "name")

1129 <|> do try (lchar '%' *> reserved "name")

1116− ty <- fnName

1130+ ty <- fst <$> fnName

1117− ns <- sepBy1 name (lchar ',')

1131+ ns <- sepBy1 (fst <$> name) (lchar ',')

1118 return [PDirective (DNameHint ty ns)]

1132 return [PDirective (DNameHint ty ns)]

1119 <|> do try (lchar '%' *> reserved "error_handlers")

1133 <|> do try (lchar '%' *> reserved "error_handlers")

1120− fn <- fnName

1134+ fn <- fst <$> fnName

1121− arg <- fnName

1135+ arg <- fst <$> fnName

1122− ns <- sepBy1 name (lchar ',')

1136+ ns <- sepBy1 (fst <$> name) (lchar ',')

1123 return [PDirective (DErrorHandlers fn arg ns) ]

1137 return [PDirective (DErrorHandlers fn arg ns) ]

1124 <|> do try (lchar '%' *> reserved "language"); ext <- pLangExt;

1138 <|> do try (lchar '%' *> reserved "language"); ext <- pLangExt;

1125 return [PDirective (DLanguage ext)]

1139 return [PDirective (DLanguage ext)]

1126 <|> do fc <- getFC

1140 <|> do fc <- getFC

1127 try (lchar '%' *> reserved "used")

1141 try (lchar '%' *> reserved "used")

1128− fn <- fnName

1142+ fn <- fst <$> fnName

1129− arg <- iName []

1143+ arg <- fst <$> iName []

1130 return [PDirective (DUsed fc fn arg)]

1144 return [PDirective (DUsed fc fn arg)]

1131 <?> "directive"

1145 <?> "directive"

1132

1146

@@ -1161,14 +1175,14 @@ provider syn = do doc <- try (do (doc, _) <- docstring syn

1161 provideTerm doc <|> providePostulate doc

1175 provideTerm doc <|> providePostulate doc

1162 <?> "type provider"

1176 <?> "type provider"

1163 where provideTerm doc =

1177 where provideTerm doc =

1164− do lchar '('; n <- fnName; lchar ':'; t <- typeExpr syn; lchar ')'

1178+ do lchar '('; n <- fst <$> fnName; lchar ':'; t <- typeExpr syn; lchar ')'

1165 fc <- getFC

1179 fc <- getFC

1166 reserved "with"

1180 reserved "with"

1167 e <- expr syn <?> "provider expression"

1181 e <- expr syn <?> "provider expression"

1168 return [PProvider doc syn fc (ProvTerm t e) n]

1182 return [PProvider doc syn fc (ProvTerm t e) n]

1169 providePostulate doc =

1183 providePostulate doc =

1170 do reserved "postulate"

1184 do reserved "postulate"

1171− n <- fnName

1185+ n <- fst <$> fnName

1172 fc <- getFC

1186 fc <- getFC

1173 reserved "with"

1187 reserved "with"

1174 e <- expr syn <?> "provider expression"

1188 e <- expr syn <?> "provider expression"

@@ -1201,7 +1215,7 @@ parseExpr st = runparser (fullExpr defaultSyntax) st "(input)"

1201

1215

1202{- | Parses a constant form input -}

1216{- | Parses a constant form input -}

1203parseConst :: IState -> String -> Result Const

1217parseConst :: IState -> String -> Result Const

1204−parseConst st = runparser constant st "(input)"

1218+parseConst st = runparser (fmap fst constant) st "(input)"

1205

1219

1206{- | Parses a tactic from input -}

1220{- | Parses a tactic from input -}

1207parseTactic :: IState -> String -> Result PTactic

1221parseTactic :: IState -> String -> Result PTactic

src/Idris/PartialEval.hs+3−3

@@ -128,12 +128,12 @@ mkPE_TyDecl :: IState -> [(PEArgType, Term)] -> Type -> PTerm

128mkPE_TyDecl ist args ty = mkty args ty

129 where

130 mkty ((ExplicitD, v) : xs) (Bind n (Pi _ t k) sc)

131− = PPi expl n (delab ist (generaliseIn t)) (mkty xs sc)

131+ = PPi expl n NoFC (delab ist (generaliseIn t)) (mkty xs sc)

132 mkty ((ImplicitD, v) : xs) (Bind n (Pi _ t k) sc)

133 | concreteClass ist t = mkty xs sc

134 | classConstraint ist t

135− = PPi constraint n (delab ist (generaliseIn t)) (mkty xs sc)

135+ = PPi constraint n NoFC (delab ist (generaliseIn t)) (mkty xs sc)

136− | otherwise = PPi impl n (delab ist (generaliseIn t)) (mkty xs sc)

136+ | otherwise = PPi impl n NoFC (delab ist (generaliseIn t)) (mkty xs sc)

137

138 mkty (_ : xs) t

139 = mkty xs t

src/Idris/Prover.hs+1−1

@@ -297,7 +297,7 @@ ploop fn d prompt prf e h

297 infixes = idris_infixes ist

298 action = case tm of

299 TType _ ->

300− iPrintTermWithType (prettyImp ppo PType) type1Doc

300+ iPrintTermWithType (prettyImp ppo (PType emptyFC)) type1Doc

301 _ -> let bnd = map (\x -> (fst x, False)) env in

302 iPrintTermWithType (pprintPTerm ppo bnd [] infixes (delab ist tm))

303 (pprintPTerm ppo bnd [] infixes (delab ist ty))

src/Idris/REPL.hs+17−17

@@ -438,7 +438,7 @@ runIdeModeCommand h id orig fn mods (IdeMode.Metavariables cols) =

438 in

439 displaySpans .

440 renderPretty 0.9 cols .

441− fmap (fancifyAnnots ist) .

441+ fmap (fancifyAnnots ist True) .

442 annotate (AnnTerm (zip bnd (take (length bnd) (repeat False))) t) $

443 prettyT

444

@@ -463,7 +463,7 @@ runIdeModeCommand h id orig fn mods (IdeMode.WhoCalls n) =

463 runIO . hPutStrLn h $ IdeMode.convSExp "return" msg id

464 where pn ist = displaySpans .

465 renderPretty 0.9 1000 .

466− fmap (fancifyAnnots ist) .

466+ fmap (fancifyAnnots ist True) .

467 prettyName True True []

468

469runIdeModeCommand h id orig fn mods (IdeMode.CallsWho n) =

@@ -476,7 +476,7 @@ runIdeModeCommand h id orig fn mods (IdeMode.CallsWho n) =

476 runIO . hPutStrLn h $ IdeMode.convSExp "return" msg id

477 where pn ist = displaySpans .

478 renderPretty 0.9 1000 .

479− fmap (fancifyAnnots ist) .

479+ fmap (fancifyAnnots ist True) .

480 prettyName True True []

481

482runIdeModeCommand h id orig fn modes (IdeMode.BrowseNS ns) =

@@ -491,7 +491,7 @@ runIdeModeCommand h id orig fn modes (IdeMode.BrowseNS ns) =

491 runIO . hPutStrLn h $ IdeMode.convSExp "return" msg id

492 where pn ist = displaySpans .

493 renderPretty 0.9 1000 .

494− fmap (fancifyAnnots ist) .

494+ fmap (fancifyAnnots ist True) .

495 prettyName True True []

496runIdeModeCommand h id orig fn modes (IdeMode.TermNormalise bnd tm) =

497 do ctxt <- getContext

@@ -506,7 +506,7 @@ runIdeModeCommand h id orig fn modes (IdeMode.TermNormalise bnd tm) =

506 msg = (IdeMode.SymbolAtom "ok",

507 displaySpans .

508 renderPretty 0.9 80 .

509− fmap (fancifyAnnots ist) $ ptm)

509+ fmap (fancifyAnnots ist True) $ ptm)

510 runIO . hPutStrLn h $ IdeMode.convSExp "return" msg id

511runIdeModeCommand h id orig fn modes (IdeMode.TermShowImplicits bnd tm) =

512 ideModeForceTermImplicits h id bnd True tm

@@ -519,7 +519,7 @@ runIdeModeCommand h id orig fn modes (IdeMode.TermElab bnd tm) =

519 msg = (IdeMode.SymbolAtom "ok",

520 displaySpans .

521 renderPretty 0.9 70 .

522− fmap (fancifyAnnots ist) $ ptm)

522+ fmap (fancifyAnnots ist True) $ ptm)

523 runIO . hPutStrLn h $ IdeMode.convSExp "return" msg id

524runIdeModeCommand h id orig fn mods (IdeMode.PrintDef name) =

525 case splitName name of

@@ -535,7 +535,7 @@ runIdeModeCommand h id orig fn modes (IdeMode.ErrPPrint e) =

535 let (out, spans) =

536 displaySpans .

537 renderPretty 0.9 80 .

538− fmap (fancifyAnnots ist) $ pprintErr ist e

538+ fmap (fancifyAnnots ist True) $ pprintErr ist e

539 msg = (IdeMode.SymbolAtom "ok", out, spans)

540 runIO . hPutStrLn h $ IdeMode.convSExp "return" msg id

541runIdeModeCommand h id orig fn modes IdeMode.GetIdrisVersion =

@@ -558,7 +558,7 @@ ideModeForceTermImplicits h id bnd impl tm =

558 msg = (IdeMode.SymbolAtom "ok",

559 displaySpans .

560 renderPretty 0.9 80 .

561− fmap (fancifyAnnots ist) $ expl)

561+ fmap (fancifyAnnots ist True) $ expl)

562 runIO . hPutStrLn h $ IdeMode.convSExp "return" msg id

563

564splitName :: String -> Either String Name

@@ -788,16 +788,16 @@ process fn (NewDefn decls) = do

788 mapM_ defineName namedGroups where

789 namedGroups = groupBy (\d1 d2 -> getName d1 == getName d2) decls

790 getName :: PDecl -> Maybe Name

791− getName (PTy docs argdocs syn fc opts name ty) = Just name

791+ getName (PTy docs argdocs syn fc opts name _ ty) = Just name

792 getName (PClauses fc opts name (clause:clauses)) = Just (getClauseName clause)

793 getName (PData doc argdocs syn fc opts dataDecl) = Just (d_name dataDecl)

794− getName (PClass doc syn fc constraints name parms parmdocs fds decls _ _) = Just name

794+ getName (PClass doc syn fc constraints name nfc parms parmdocs fds decls _ _) = Just name

795 getName _ = Nothing

796 -- getClauseName is partial and I am not sure it's used safely! -- trillioneyes

797 getClauseName (PClause fc name whole with rhs whereBlock) = name

798 getClauseName (PWith fc name whole with rhs pn whereBlock) = name

799 defineName :: [PDecl] -> Idris ()

800− defineName (tyDecl@(PTy docs argdocs syn fc opts name ty) : decls) = do

800+ defineName (tyDecl@(PTy docs argdocs syn fc opts name _ ty) : decls) = do

801 elabDecl EAll recinfo tyDecl

802 elabClauses recinfo fc opts name (concatMap getClauses decls)

803 setReplDefined (Just name)

@@ -839,8 +839,8 @@ process fn (NewDefn decls) = do

839 fixClauses :: PDecl' t -> PDecl' t

840 fixClauses (PClauses fc opts _ css@(clause:cs)) =

841 PClauses fc opts (getClauseName clause) css

842− fixClauses (PInstance doc argDocs syn fc constraints cls parms ty instName decls) =

842+ fixClauses (PInstance doc argDocs syn fc constraints cls nfc parms ty instName decls) =

843− PInstance doc argDocs syn fc constraints cls parms ty instName (map fixClauses decls)

843+ PInstance doc argDocs syn fc constraints cls nfc parms ty instName (map fixClauses decls)

844 fixClauses decl = decl

845

846process fn (Undefine names) = undefine names

@@ -896,7 +896,7 @@ process fn (Check (PRef _ n))

896 case lookupNames n ctxt of

897 ts@(t:_) ->

898 case lookup t (idris_metavars ist) of

899− Just (_, i, _) -> iRenderResult . fmap (fancifyAnnots ist) $

899+ Just (_, i, _) -> iRenderResult . fmap (fancifyAnnots ist True) $

900 showMetavarInfo ppo ist n i

901 Nothing -> iPrintFunTypes [] n (map (\n -> (n, pprintDelabTy ist n)) ts)

902 [] -> iPrintError $ "No such variable " ++ show n

@@ -906,7 +906,7 @@ process fn (Check (PRef _ n))

906 (ty:_) -> putTy ppo ist i [] (delab ist (errReverse ist ty))

907 putTy :: PPOption -> IState -> Int -> [(Name, Bool)] -> PTerm -> Doc OutputAnnotation

908 putTy ppo ist 0 bnd sc = putGoal ppo ist bnd sc

909− putTy ppo ist i bnd (PPi _ n t sc)

909+ putTy ppo ist i bnd (PPi _ n _ t sc)

910 = let current = text " " <>

911 (case n of

912 MN _ _ -> text "_"

@@ -932,7 +932,7 @@ process fn (Check t)

932 ty' = normaliseC ctxt [] ty

933 case tm of

934 TType _ ->

935− iPrintTermWithType (prettyIst ist PType) type1Doc

935+ iPrintTermWithType (prettyIst ist (PType emptyFC)) type1Doc

936 _ -> iPrintTermWithType (pprintDelab ist tm)

937 (pprintDelab ist ty)

938

@@ -1293,7 +1293,7 @@ process fn (Browse ns) =

1293process fn (MakeDoc s) =

1294 do istate <- getIState

1295 let names = words s

1296− parse n | Success x <- runparser name istate fn n = Right x

1296+ parse n | Success x <- runparser (fmap fst name) istate fn n = Right x

1297 parse n = Left n

1298 (bad, nss) = partitionEithers $ map parse names

1299 cd <- runIO $ getCurrentDirectory

src/Idris/REPLParser.hs+26−25

@@ -212,19 +212,19 @@ genArg argName argParser cmd name = do

212 failure = return $ Left ("Usage is :" ++ name ++ " <" ++ argName ++ ">")

213

214nameArg, fnNameArg :: (Name -> Command) -> String -> P.IdrisParser (Either String Command)

215−nameArg = genArg "name" P.name

215+nameArg = genArg "name" $ fst <$> P.name

216−fnNameArg = genArg "functionname" P.fnName

216+fnNameArg = genArg "functionname" $ fst <$> P.fnName

217

218strArg :: (String -> Command) -> String -> P.IdrisParser (Either String Command)

219strArg = genArg "string" (many anyChar)

220

221moduleArg :: (FilePath -> Command) -> String -> P.IdrisParser (Either String Command)

222−moduleArg = genArg "module" (fmap toPath P.identifier)

222+moduleArg = genArg "module" (fmap (toPath . fst) P.identifier)

223 where

224 toPath n = foldl1' (</>) $ splitOn "." n

225

226namespaceArg :: ([String] -> Command) -> String -> P.IdrisParser (Either String Command)

227−namespaceArg = genArg "namespace" (fmap toNS P.identifier)

227+namespaceArg = genArg "namespace" (fmap (toNS . fst) P.identifier)

228 where

229 toNS = splitOn "."

230

@@ -258,14 +258,14 @@ proofArg cmd name = do

258 upd <- option False $ do

259 P.lchar '!'

260 return True

261− l <- P.natural

261+ l <- fst <$> P.natural

262− n <- P.name;

262+ n <- fst <$> P.name;

263 return (Right (cmd upd (fromInteger l) n))

264

265cmd_doc :: String -> P.IdrisParser (Either String Command)

266cmd_doc name = do

267 let constant = do

268− c <- P.constant

268+ c <- fmap fst P.constant

269 eof

270 return $ Right (DocStr (Right c) FullDocs)

271

@@ -282,7 +282,8 @@ cmd_consolewidth name = do

282 pConsoleWidth :: P.IdrisParser ConsoleWidth

283 pConsoleWidth = do discard (P.symbol "auto"); return AutomaticWidth

284 <|> do discard (P.symbol "infinite"); return InfinitelyWide

285− <|> do n <- fmap fromInteger P.natural; return (ColsWide n)

285+ <|> do n <- fmap (fromInteger . fst) P.natural

286+ return (ColsWide n)

286

287

287cmd_execute :: String -> P.IdrisParser (Either String Command)

288cmd_execute :: String -> P.IdrisParser (Either String Command)

288cmd_execute name = do

289cmd_execute name = do

@@ -307,7 +308,7 @@ cmd_pprint :: String -> P.IdrisParser (Either String Command)

307cmd_pprint name = do

308cmd_pprint name = do

308 fmt <- ppFormat

309 fmt <- ppFormat

309 P.whiteSpace

310 P.whiteSpace

310− n <- fmap fromInteger P.natural

311+ n <- fmap (fromInteger . fst) P.natural

311 P.whiteSpace

312 P.whiteSpace

312 t <- P.fullExpr defaultSyntax

313 t <- P.fullExpr defaultSyntax

313 return (Right (PPrint fmt n t))

314 return (Right (PPrint fmt n t))

@@ -326,20 +327,20 @@ cmd_compile name = do

326 let codegenOption :: P.IdrisParser Codegen

327 let codegenOption :: P.IdrisParser Codegen

327 codegenOption = do

328 codegenOption = do

328 let bytecodeCodegen = discard (P.symbol "bytecode") *> return Bytecode

329 let bytecodeCodegen = discard (P.symbol "bytecode") *> return Bytecode

329− viaCodegen = do x <- P.identifier

330+ viaCodegen = do x <- fst <$> P.identifier

330 return (Via (map toLower x))

331 return (Via (map toLower x))

331 bytecodeCodegen <|> viaCodegen

332 bytecodeCodegen <|> viaCodegen

332

333

333 let hasOneArg = do

334 let hasOneArg = do

334 i <- get

335 i <- get

335− f <- P.identifier

336+ f <- fst <$> P.identifier

336 eof

337 eof

337 return $ Right (Compile defaultCodegen f)

338 return $ Right (Compile defaultCodegen f)

338

339

339 let hasTwoArgs = do

340 let hasTwoArgs = do

340 i <- get

341 i <- get

341 codegen <- codegenOption

342 codegen <- codegenOption

342− f <- P.identifier

343+ f <- fst <$> P.identifier

343 eof

344 eof

344 return $ Right (Compile codegen f)

345 return $ Right (Compile codegen f)

345

346

@@ -349,16 +350,16 @@ cmd_compile name = do

349cmd_addproof :: String -> P.IdrisParser (Either String Command)

350cmd_addproof :: String -> P.IdrisParser (Either String Command)

350cmd_addproof name = do

351cmd_addproof name = do

351 n <- option Nothing $ do

352 n <- option Nothing $ do

352− x <- P.name;

353+ x <- fst <$> P.name

353 return (Just x)

354 return (Just x)

354 eof

355 eof

355 return (Right (AddProof n))

356 return (Right (AddProof n))

356

357

357cmd_log :: String -> P.IdrisParser (Either String Command)

358cmd_log :: String -> P.IdrisParser (Either String Command)

358cmd_log name = do

359cmd_log name = do

359− i <- P.natural

360+ i <- fmap (fromIntegral . fst) P.natural

360 eof

361 eof

361− return (Right (LogLvl (fromIntegral i)))

362+ return (Right (LogLvl i))

362

363

363cmd_let :: String -> P.IdrisParser (Either String Command)

364cmd_let :: String -> P.IdrisParser (Either String Command)

364cmd_let name = do

365cmd_let name = do

@@ -366,13 +367,13 @@ cmd_let name = do

366 return (Right (NewDefn defn))

367 return (Right (NewDefn defn))

367

368

368cmd_unlet :: String -> P.IdrisParser (Either String Command)

369cmd_unlet :: String -> P.IdrisParser (Either String Command)

369−cmd_unlet name = (Right . Undefine) `fmap` many P.name

370+cmd_unlet name = (Right . Undefine) `fmap` many (fst <$> P.name)

370

371

371cmd_loadto :: String -> P.IdrisParser (Either String Command)

372cmd_loadto :: String -> P.IdrisParser (Either String Command)

372cmd_loadto name = do

373cmd_loadto name = do

373− toline <- P.natural

374+ toline <- fmap (fromInteger . fst) P.natural

374 f <- many anyChar;

375 f <- many anyChar;

375− return (Right (Load f (Just (fromInteger toline))))

376+ return (Right (Load f (Just toline)))

376

377

377cmd_colour :: String -> P.IdrisParser (Either String Command)

378cmd_colour :: String -> P.IdrisParser (Either String Command)

378cmd_colour name = fmap Right pSetColourCmd

379cmd_colour name = fmap Right pSetColourCmd

@@ -452,19 +453,19 @@ packageBasedCmd valParser cmd name = do

452 return (Right (cmd pkgs val))

453 return (Right (cmd pkgs val))

453

454

454cmd_search :: String -> P.IdrisParser (Either String Command)

455cmd_search :: String -> P.IdrisParser (Either String Command)

455−cmd_search = packageBasedCmd

456+cmd_search = packageBasedCmd

456 (P.typeExpr (defaultSyntax { implicitAllowed = True })) Search

457 (P.typeExpr (defaultSyntax { implicitAllowed = True })) Search

457

458

458cmd_proofsearch :: String -> P.IdrisParser (Either String Command)

459cmd_proofsearch :: String -> P.IdrisParser (Either String Command)

459cmd_proofsearch name = do

460cmd_proofsearch name = do

460 upd <- option False (do P.lchar '!'; return True)

461 upd <- option False (do P.lchar '!'; return True)

461− l <- P.natural; n <- P.name;

462+ l <- fmap (fromInteger . fst) P.natural; n <- fst <$> P.name

462− hints <- many P.fnName

463+ hints <- many (fst <$> P.fnName)

463− return (Right (DoProofSearch upd True (fromInteger l) n hints))

464+ return (Right (DoProofSearch upd True l n hints))

464

465

465cmd_refine :: String -> P.IdrisParser (Either String Command)

466cmd_refine :: String -> P.IdrisParser (Either String Command)

466cmd_refine name = do

467cmd_refine name = do

467 upd <- option False (do P.lchar '!'; return True)

468 upd <- option False (do P.lchar '!'; return True)

468− l <- P.natural; n <- P.name;

469+ l <- fmap (fromInteger . fst) P.natural; n <- fst <$> P.name

469− hint <- P.fnName

470+ hint <- fst <$> P.fnName

470− return (Right (DoProofSearch upd False (fromInteger l) n [hint]))

471+ return (Right (DoProofSearch upd False l n [hint]))

src/Idris/TypeSearch.hs+1−1

@@ -47,7 +47,7 @@ searchByType pkgs pterm = do

47 pterm' <- addUsingConstraints syn emptyFC pterm

48 pterm'' <- implicit toplevel syn name pterm'

49 let pterm''' = addImpl [] i pterm''

50− ty <- elabType toplevel syn (fst noDocs) (snd noDocs) emptyFC [] name pterm'

50+ ty <- elabType toplevel syn (fst noDocs) (snd noDocs) emptyFC [] name NoFC pterm'

51 let names = searchUsing searchPred i ty

52 let names' = take numLimit names

53 let docs =

src/Pkg/PParser.hs+13−10

@@ -5,12 +5,12 @@

6module Pkg.PParser where

8−import Text.Trifecta hiding (span, stringLiteral, charLiteral, natural, symbol, char, string, whiteSpace)

8+import Text.Trifecta hiding (span, charLiteral, natural, symbol, char, string, whiteSpace)

10import Idris.Core.TT

11import Idris.REPL

12import Idris.AbsSyntaxTree

13−import Idris.ParseHelpers

13+import Idris.ParseHelpers hiding (stringLiteral)

14import Idris.CmdOptions

16import Control.Monad.State.Strict

@@ -34,6 +34,9 @@ data PkgDesc = PkgDesc { pkgname :: String,

34 }

35 deriving Show

37+instance HasLastTokenSpan PParser where

38+ getLastTokenSpan = return Nothing

39+

37#if MIN_VERSION_base(4,8,0)

40#if MIN_VERSION_base(4,8,0)

38instance {-# OVERLAPPING #-} TokenParsing PParser where

41instance {-# OVERLAPPING #-} TokenParsing PParser where

39#else

42#else

@@ -51,7 +54,7 @@ parseDesc fp = do p <- readFile fp

51 Success x -> return x

54 Success x -> return x

53pPkg :: PParser PkgDesc

56pPkg :: PParser PkgDesc

54−pPkg = do reserved "package"; p <- identifier

57+pPkg = do reserved "package"; p <- fst <$> identifier

55 st <- get

58 st <- get

56 put (st { pkgname = p })

59 put (st { pkgname = p })

57 some pClause

60 some pClause

@@ -68,11 +71,11 @@ pClause = do reserved "executable"; lchar '=';

68 else ( show exec )

71 else ( show exec )

69 ) })

72 ) })

70 <|> do reserved "main"; lchar '=';

73 <|> do reserved "main"; lchar '=';

71− main <- iName []

74+ main <- fst <$> iName []

72 st <- get

75 st <- get

73 put (st { idris_main = main })

76 put (st { idris_main = main })

74 <|> do reserved "sourcedir"; lchar '=';

77 <|> do reserved "sourcedir"; lchar '=';

75− src <- identifier

78+ src <- fst <$> identifier

76 st <- get

79 st <- get

77 put (st { sourcedir = src })

80 put (st { sourcedir = src })

78 <|> do reserved "opts"; lchar '=';

81 <|> do reserved "opts"; lchar '=';

@@ -81,23 +84,23 @@ pClause = do reserved "executable"; lchar '=';

81 let args = pureArgParser (words opts)

84 let args = pureArgParser (words opts)

82 put (st { idris_opts = args })

85 put (st { idris_opts = args })

83 <|> do reserved "modules"; lchar '=';

86 <|> do reserved "modules"; lchar '=';

84− ms <- sepBy1 (iName []) (lchar ',')

87+ ms <- sepBy1 (fst <$> iName []) (lchar ',')

85 st <- get

88 st <- get

86 put (st { modules = modules st ++ ms })

89 put (st { modules = modules st ++ ms })

87 <|> do reserved "libs"; lchar '=';

90 <|> do reserved "libs"; lchar '=';

88− ls <- sepBy1 identifier (lchar ',')

91+ ls <- sepBy1 (fst <$> identifier) (lchar ',')

89 st <- get

92 st <- get

90 put (st { libdeps = libdeps st ++ ls })

93 put (st { libdeps = libdeps st ++ ls })

91 <|> do reserved "objs"; lchar '=';

94 <|> do reserved "objs"; lchar '=';

92− ls <- sepBy1 identifier (lchar ',')

95+ ls <- sepBy1 (fst <$> identifier) (lchar ',')

93 st <- get

96 st <- get

94 put (st { objs = libdeps st ++ ls })

97 put (st { objs = libdeps st ++ ls })

95 <|> do reserved "makefile"; lchar '=';

98 <|> do reserved "makefile"; lchar '=';

96− mk <- iName []

99+ mk <- fst <$> iName []

97 st <- get

100 st <- get

98 put (st { makefile = Just (show mk) })

101 put (st { makefile = Just (show mk) })

99 <|> do reserved "tests"; lchar '=';

102 <|> do reserved "tests"; lchar '=';

100− ts <- sepBy1 (iName []) (lchar ',')

103+ ts <- sepBy1 (fst <$> iName []) (lchar ',')

101 st <- get

104 st <- get

102 put st { idris_tests = idris_tests st ++ ts }

105 put st { idris_tests = idris_tests st ++ ts }

103

106

test/reg007/expected+1−1

@@ -1,5 +1,5 @@

1reg007.lidr:8:1:A.n is already defined

2−reg007.lidr:12:11:When elaborating right hand side of hurrah:

2+reg007.lidr:12:11-17:When elaborating right hand side of hurrah:

3Can't unify

4 n = lala (Type of isSame)

5with

test/sourceLocation001/expected+2−2

@@ -1,11 +1,11 @@

1Testing using definition

2−FileLoc "SourceLoc.idr" (16, 11) (16, 11)

2+FileLoc "SourceLoc.idr" (16, 11) (16, 17)

3Testing using inline tactics

4FileLoc "SourceLoc.idr" (20, 17) (20, 17)

5Testing using metavariable with later definition

6FileLoc "SourceLoc.idr" (98, 16) (98, 16)

7-----------------------

8Success!

9−Error at FileLoc "SourceLoc.idr" (72, 23) (72, 23)

9+Error at FileLoc "SourceLoc.idr" (72, 23) (72, 26)

10Success!

11Success!

test/tutorial006/expected+2−1

@@ -1,4 +1,5 @@

1+tutorial006a.idr:5:23-25:

1−tutorial006a.idr:5:23:When elaborating right hand side of vapp:

2+When elaborating right hand side of vapp:

2When elaborating argument xs to constructor Data.VectType.Vect.:::

3When elaborating argument xs to constructor Data.VectType.Vect.:::

3 Can't unify

4 Can't unify

4 Vect (n + n) a (Type of vapp xs xs)

5 Vect (n + n) a (Type of vapp xs xs)