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

git.iko.soy/Idris-dev

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

Agda-style source code highlighting

commit591556a2697797a1e297870cfa40b8c5dce1d0ff authorDavid Christiansen <david@davidchristiansen.dk> dateTue 12 May 2015, 12:45 (11 years ago) parentf07ac48 7e8e25b

45 files changed+1354−1009

compare with master

unifiedsplit

src/Idris/AbsSyntax.hs+111−109 src/Idris/AbsSyntaxTree.hs+109−100 src/Idris/CaseSplit.hs+6−6 src/Idris/Core/Binary.hs+19−8 src/Idris/Core/DeepSeq.hs+2 src/Idris/Core/TT.hs+65−9 src/Idris/Coverage.hs+4−4 src/Idris/DSL.hs+28−28 src/Idris/DeepSeq.hs+33−21 src/Idris/Delaborate.hs+25−22 src/Idris/Docs.hs+15−15 src/Idris/Elab/AsPat.hs+1−1 src/Idris/Elab/Class.hs+68−53 src/Idris/Elab/Clause.hs+30−16 src/Idris/Elab/Data.hs+31−25 src/Idris/Elab/Instance.hs+22−20 src/Idris/Elab/Provider.hs+2−2 src/Idris/Elab/Record.hs+61−50 src/Idris/Elab/Term.hs+106−45 src/Idris/Elab/Transform.hs+5−3 src/Idris/Elab/Type.hs+14−9 src/Idris/Elab/Utils.hs+9−9 src/Idris/Elab/Value.hs+7−6 src/Idris/ElabDecls.hs+9−9 src/Idris/ElabQuasiquote.hs+10−10 src/Idris/Error.hs+8−8 src/Idris/IBC.hs+74−48 src/Idris/IdeMode.hs+2 src/Idris/IdrisDoc.hs+10−10 src/Idris/Interactive.hs+6−6 src/Idris/Output.hs+28−10 src/Idris/ParseData.hs+51−49 src/Idris/ParseExpr.hs+122−112 src/Idris/ParseHelpers.hs+84−35 src/Idris/ParseOps.hs+19−12 src/Idris/Parser.hs+92−78 src/Idris/PartialEval.hs+3−3 src/Idris/Prover.hs+1−1 src/Idris/REPL.hs+17−17 src/Idris/REPLParser.hs+26−25 src/Idris/TypeSearch.hs+1−1 src/Pkg/PParser.hs+13−10 test/reg007/expected+1−1 test/sourceLocation001/expected+2−2 test/tutorial006/expected+2−1

src/Idris/AbsSyntax.hs+111−109

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

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

953953 mkShadow (NS x s) = NS (mkShadow x) s

954954

955− en (PLam fc n t s)

955+ en (PLam fc n nfc t s)

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

957957 = let n' = mkShadow n in

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

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

960− en (PPi p n t s)

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

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

960+ en (PPi p n nfc t s)

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

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

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

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

965− en (PLet fc n ty v s)

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

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

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

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

967967 = let n' = mkShadow n in

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

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

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

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

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

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

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

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

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

10281028 IState ->

10291029 (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)

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

10321032 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))

10341034 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)

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

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

10381038 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)

10851085 where

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

10871087 -- added implicitly)

1088− expandPData (PDatadecl n ty cons)

1088+ expandPData (PDatadecl n nfc ty cons)

10891089 = 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))

10911091 (map econ cons)

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

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

1094− = (doc, argDocs, dec n, 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)

1096− = d

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

1093+ econ (doc, argDocs, n, nfc, 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 nfc prs pdocs fls cn cdoc csyn)

1096+ = d

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

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

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

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

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

11021102 = 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)

11041104 = PClass doc info f

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

1106− n

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

1106+ n nfc

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

11081108 pDocs

11091109 fds

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

11111111 cn

11121112 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)

11141114 = PInstance doc argDocs info f

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

11161116 n

1117+ nfc

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

11181119 (expandParams dec ps ns [] ty)

11191120 cn

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

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

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

11391140 [] -> 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))

11411142 pri (PTrue _ _) = 0

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

11431144 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

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

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

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

1150− pri (PConstant _) = 0

1151+ pri (PConstant _ _) = 0

11511152 pri Placeholder = 1

11521153 pri _ = 3

11531154

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

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

11821183 addIBC (IBCStatic n)

11831184 where

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

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

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

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

11861187 (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)

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

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

11901191 else if (not (searchArg p))

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

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

12541255 doAdd (UConstraint c args : cs) ns t

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

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

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

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

12581259 | otherwise = doAdd cs ns t

12591260

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

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

12621263

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

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

12641265 = getcapp c ++ getConstraints sc

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

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

12661267 getConstraints _ = []

12671268

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

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

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

13001301 doAdd (UImplicit n ty : cs) ns t

13011302 | 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)

13031304 | otherwise = doAdd cs ns t

13041305

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

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

13071308 bindFree (n:ns) tm

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

13091310 | otherwise

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

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

13111312

1312− getArgnames (PPi _ n c sc)

1313+ getArgnames (PPi _ n _ c sc)

13131314 = n : getArgnames sc

13141315 getArgnames _ = []

13151316

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

13181319

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

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

1321− where collectImps (PPi p n t sc)

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

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

13231324 collectImps _ = []

13241325

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

14181419 = do (decls, ns) <- get

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

14201421 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)

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

14231424 (decls , ns) <- get

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

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

14261427 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)

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

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

14301431 _ -> [])

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

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

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

14341435 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)

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

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

14381439 _ -> [])

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

14401441 put (PConstraint 10 l n Placeholder : decls,

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

14421443 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)

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

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

14461447 _ -> [])

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

14711472 = do (decls, ns) <- get

14721473 let isn = concatMap (namesIn uvars ist) as

14731474 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)

14751476 = do imps False env ty

14761477 imps False (n:env) sc

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

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

14831484 pibind using [] sc = sc

14841485 pibind using (n:ns) sc

14851486 = case lookup n using of

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

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

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

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

14881489 (pibind using ns sc)

14891490

14901491-- Add implicit arguments in function calls

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

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

15151516 ai qq env ds (PRef fc f)

15161517 | 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 []

15181519 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 [])

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

15211522 = let l' = ai qq env ds l

15221523 r' = ai qq env ds r

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

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

15401541 PAlternative a as'

15411542 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)

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

1544− PApp fc (PInferRef fc f) as'

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

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

1545+ PApp fc (PInferRef ffc f) as'

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

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

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

15481549 = 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'

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

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

15521553 arity = getPArity ty in

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

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

15621563 -- information

15631564 PCase fc c' os

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

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

1566− -- be lifted anyway!)

1565+

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

15681567 (ai qq env ds t)

15691568 (ai qq env ds f)

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

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!)

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

15711574 = case lookupDef n (tt_ctxt ist) of

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

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

1574− PLam fc n ty' sc'

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

1577+ PLam fc n nfc ty' sc'

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

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

15771580 [(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)

15791582 = case lookupDef n (tt_ctxt ist) of

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

15811584 val' = ai qq env ds val

15821585 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'

15841587 _ -> 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)

15861589 = let ty' = ai qq env ds ty

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

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

15891592 sc' = ai qq env' ds sc in

1590− PPi p n ty' sc'

1593+ PPi p n nfc ty' sc'

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

15921595 = let r' = ai qq env ds r

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

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

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

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

16111614

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

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

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

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

16141617 = case lookupDef f (tt_ctxt ist) of

1615− [] -> Right $ PPatvar fc f

1618+ [] -> Right $ PPatvar ffc f

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

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

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

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

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

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

1622− else Right $ PPatvar fc f

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

1625+ else Right $ PPatvar ffc f

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

16241627 imp _ = True

16251628-- allImp [] = False

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

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

16331636 vname _ = False

16341637

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

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

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

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

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

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

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

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

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

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

16421645 [] -> nh

16431646 x -> x

16441647 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)

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

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

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

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

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

16491652 alts -> Right $

16501653 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'))

16521655 (insertImpl ns as)) alts

16531656 where

16541657 -- 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

16731676 _ -> Public

16741677

16751678 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)

16771680

16781681 exp (PExp _ _ _ _) = True

16791682 exp (PConstraint _ _ _ _) = True

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

17741777 return $ PTacImplicit p l n sc t'

17751778 sl x = return x

17761779

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

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

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

17791782-- filled in (so no ambiguity).

1780−

17811783stripUnmatchable :: IState -> PTerm -> PTerm

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

17831785 su :: PTerm -> PTerm

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

17991801 else PAlternative b alts'

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

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

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

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

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

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

18041806 su t = t

18051807

18061808 ctxt = tt_ctxt i

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

18231825findStatics ist tm = trace (show tm) $

18241826 let (ns, ss) = fs tm in

18251827 runState (pos ns ss tm) []

1826− where fs (PPi p n t sc)

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

18271829 | Static <- pstatic p

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

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

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

18331835

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

18351837

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

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

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

18381840 spos <- get

18391841 put (True : spos)

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

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

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

18421844 spos <- get

18431845 put (False : spos)

1844− return (PPi p n t sc')

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

18451847 pos ns ss t = return t

18461848

18471849-- for 6.12/7 compatibility

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

1940− ms <- match' s s'

1941− return (mt ++ ms)

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

1943− ms <- match' s s'

1944− return (mt ++ ms)

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

1946− mty <- match' ty ty'

1947− ms <- match' s s'

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

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

1942+ ms <- match' s s'

1943+ return (mt ++ ms)

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

1945+ ms <- match' s s'

1946+ return (mt ++ ms)

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

1948+ mty <- match' ty ty'

1949+ ms <- match' s s'

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

19491951 match (PHidden x) (PHidden y)

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

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

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

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

19891991substMatchShadow n shs tm t = sm shs t where

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

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

1992− sm xs (PPi p x t sc)

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

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

19931995 | x `elem` xs

19941996 = let x' = nextName x in

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

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

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

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

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

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

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

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

20002002 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

20162018shadow :: Name -> Name -> PTerm -> PTerm

20172019shadow n n' t = sm t where

20182020 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)

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

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

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

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

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

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

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

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

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

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

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

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

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

20272029 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

20602062 mkUniqT tac = return tac

20612063

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

2063− mkUniq (PLam fc n ty sc)

2065+ mkUniq (PLam fc n nfc ty sc)

20642066 = do env <- get

20652067 (n', sc') <-

20662068 if n `S.member` env

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

20712073 put (S.insert n' env)

20722074 ty' <- mkUniq ty

20732075 sc'' <- mkUniq sc'

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

2075− mkUniq (PPi p n ty sc)

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

2077+ mkUniq (PPi p n fc ty sc)

20762078 = do env <- get

20772079 (n', sc') <-

20782080 if n `S.member` env

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

20832085 put (S.insert n' env)

20842086 ty' <- mkUniq ty

20852087 sc'' <- mkUniq sc'

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

2087− mkUniq (PLet fc n ty val sc)

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

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

20882090 = do env <- get

20892091 (n', sc') <-

20902092 if n `S.member` env

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

20952097 put (S.insert n' env)

20962098 ty' <- mkUniq ty; val' <- mkUniq val

20972099 sc'' <- mkUniq sc'

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

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

20992101 mkUniq (PApp fc t args)

21002102 = do t' <- mkUniq t

21012103 args' <- mapM mkUniqA args

src/Idris/AbsSyntaxTree.hs+109−100

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

593593-- datatypes and typeclasses.

594594data PDecl' t

595595 = 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)

597597 | PPostulate Bool -- external def if true

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

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

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

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

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

605605 Name -- Record name

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

606+ FC -- Record name precise location

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

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

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

609− (Maybe Name) -- Optional constructor name

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

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

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

611612 SyntaxInfo -- Constructor SyntaxInfo

612613 -- ^ Record declaration

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

614615 [(Name, t)] -- constraints

615616 Name -- class name

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

617+ FC -- accurate location of class name

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

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

618− [Name] -- determining parameters

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

619621 [PDecl' t] -- declarations

620− (Maybe Name) -- instance constructor name

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

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

622624 -- ^ 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

624626 | PInstance

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

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

627629 SyntaxInfo

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

629631 Name -- class

632+ FC -- precise location of class

630633 [t] -- parameters

631634 t -- full instance type

632635 (Maybe Name) -- explicit name

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

672675data EState = EState {

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

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

675− new_tyDecls :: [RDeclInstructions]

678+ new_tyDecls :: [RDeclInstructions],

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

676680 }

677681

678682initEState :: EState

679−initEState = EState [] [] []

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

680684

681685type ElabD a = Elab' EState a

682686

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

688+highlightSource fc annot =

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

690+

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

684692--

685693-- 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

690698--

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

692700

693−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]

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

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

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

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

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

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

697705 deriving Functor

698706{-!

699707deriving instance Binary PClause'

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

702710

703711-- | Data declaration

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

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

705714 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

707716 }

708717 -- ^ Data declaration

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

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

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

711720 deriving Functor

712721{-!

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

725734

726735declared :: PDecl -> [Name]

727736declared (PFix _ _ _) = []

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

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

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

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

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

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

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

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

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

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

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

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

736745declared (PNamespace _ ds) = concatMap declared ds

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

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

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

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

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

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

740749declared (PDSL n _) = [n]

741750declared (PSyntax _ _) = []

742751declared (PMutual _ ds) = concatMap declared ds

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

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

747756tldeclared :: PDecl -> [Name]

748757tldeclared (PFix _ _ _) = []

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

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

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

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

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

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

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

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

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

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

755764tldeclared (PParams _ _ ds) = []

756765tldeclared (PMutual _ ds) = concatMap tldeclared ds

757766tldeclared (PNamespace _ ds) = concatMap tldeclared ds

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

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

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

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

760769tldeclared _ = []

761770

762771defined :: PDecl -> [Name]

763772defined (PFix _ _ _) = []

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

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

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

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

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

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

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

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

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

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

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

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

772781defined (PNamespace _ ds) = concatMap defined ds

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

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

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

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

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

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

776785defined (PDSL n _) = [n]

777786defined (PSyntax _ _) = []

778787defined (PMutual _ ds) = concatMap defined ds

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

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

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

809818 | PPatvar FC Name -- ^ A pattern variable

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

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

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

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

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

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

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

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

815824 | 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

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

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

827836 | PHidden PTerm -- ^ Irrelevant or hidden pattern

828− | PType -- ^ 'Type' type

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

829838 | PUniverse Universe -- ^ Some universe

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

831− | PConstant Const -- ^ Builtin types

840+ | PConstant FC Const -- ^ Builtin types

832841 | Placeholder -- ^ Underscore

833842 | PDoBlock [PDo] -- ^ Do notation

834843 | PIdiom FC PTerm -- ^ Idiom brackets

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

856865

857866mapPT :: (PTerm -> PTerm) -> PTerm -> PTerm

858867mapPT f t = f (mpt t) where

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

860− mpt (PPi p n t s) = PPi p n (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)

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

869+ mpt (PPi p n nfc t s) = PPi p n nfc (mapPT f t) (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)

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

863872 (fmap (mapPT f) g)

864873 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

945954type PTactic = PTactic' PTerm

946955

947956data PDo' t = DoExp FC t

948− | DoBind FC Name t

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

949958 | 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

951960 | DoLetP FC t t

952961 deriving (Eq, Functor, Data, Typeable)

953962{-!

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

957966

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

959968 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

961970 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

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

964973

965974type PDo = PDo' PTerm

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

10141023highestFC (PRef fc _) = Just fc

10151024highestFC (PInferRef fc _) = Just fc

10161025highestFC (PPatvar fc _) = Just fc

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

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

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

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

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

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

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

10211030highestFC (PApp fc _ _) = Just fc

10221031highestFC (PAppBind fc _ _) = Just fc

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

10341043 [] -> Nothing

10351044 (fc:_) -> Just fc

10361045highestFC (PHidden _) = Nothing

1037−highestFC PType = Nothing

1046+highestFC (PType fc) = Just fc

10381047highestFC (PUniverse _) = Nothing

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

1040−highestFC (PConstant _) = Nothing

1049+highestFC (PConstant fc _) = Just fc

10411050highestFC Placeholder = Nothing

10421051highestFC (PDoBlock lines) =

10431052 case map getDoFC lines of

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

10451054 (fc:_) -> Just fc

10461055 where

10471056 getDoFC (DoExp fc t) = fc

1048− getDoFC (DoBind fc nm t) = fc

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

10491058 getDoFC (DoBindP fc l r alts) = fc

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

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

10511060 getDoFC (DoLetP fc l r) = fc

10521061

10531062highestFC (PIdiom fc _) = Just fc

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

12521261

12531262inferTy = sMN 0 "__Infer"

12541263inferCon = sMN 0 "__infer"

1255−inferDecl = PDatadecl inferTy

1256− PType

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

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

1264+inferDecl = PDatadecl inferTy NoFC

1265+ (PType bi)

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

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

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

12601269inferOpts = []

12611270

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

13091318 "\n\n" ++

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

13111320

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

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

1314− PType))

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

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

1323+ (PType bi)))

13151324 [(reflDoc, reflParamDoc,

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

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

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

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

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

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

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

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

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

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

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

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

13221331 where n a = sUN a

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

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

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

13481357

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

13501359piBindp 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)

13521361

13531362

13541363-- Pretty-printing declarations and terms

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

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

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

14391448 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) =

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

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

14431452 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) =

14451454 bracket p startPrec . group . align $

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

14471456 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)

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

14501459 bracket p startPrec . group $

14511460 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

14581467 case s of

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

14601469 _ -> 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)

14621471 | ppopt_impl ppo =

14631472 bracket p startPrec $

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

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

14691478 case s of

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

14711480 _ -> empty

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

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

14731482 bracket p startPrec $

14741483 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) =

14761485 bracket p startPrec $

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

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

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

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

15261535 group (prettySe right bnd r)

15271536 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,

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

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

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

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

16011610 where

16021611 prettyAs =

16031612 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"

16051614 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))

16071616 -- XXX: add pretty for tactics

16081617 prettySe p bnd (PProof ts) =

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

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

17631772

17641773

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

1766−showDImp ppo (PDatadecl n ty cons)

1775+showDImp ppo (PDatadecl n nfc ty cons)

17671776 = 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))

17691778

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

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

17721781

17731782showDeclImp _ (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

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

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

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

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

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

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

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

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

17821791 = 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)

17841793 = text "instance" <+> text (show cs) <+> text (show n) <+> prettyImp o t <> line <> showDecls o ds

17851794showDeclImp _ _ = text "..."

17861795-- showDeclImp (PImport o) = "import " ++ o

@@ -1857,9 +1866,9 @@ showTmImpls = flip (displayS . renderCompact . prettyImp verbosePPOption) ""

18571866instance Sized PTerm where

18581867 size (PQuote rawTerm) = size rawTerm

18591868 size (PRef fc name) = size name

1860− size (PLam fc name ty bdy) = 1 + size ty + size bdy

1861− size (PPi plicity name ty bdy) = 1 + size ty + size bdy

1862− size (PLet fc name ty def bdy) = 1 + size ty + size def + size bdy

1869+ size (PLam fc name _ ty bdy) = 1 + size ty + size bdy

1870+ size (PPi plicity name fc ty bdy) = 1 + size ty + size fc + size bdy

1871+ size (PLet fc name nfc ty def bdy) = 1 + size ty + size def + size bdy

18631872 size (PTyped trm ty) = 1 + size trm + size ty

18641873 size (PApp fc name args) = 1 + size args

18651874 size (PAppBind fc name args) = 1 + size args

@@ -1875,9 +1884,9 @@ instance Sized PTerm where

18751884 size (PUnifyLog tm) = size tm

18761885 size (PDisamb _ tm) = size tm

18771886 size (PNoImplicits tm) = size tm

1878− size PType = 1

1887+ size (PType _) = 1

18791888 size (PUniverse _) = 1

1880− size (PConstant const) = 1 + size const

1889+ size (PConstant fc const) = 1 + size fc + size const

18811890 size Placeholder = 1

18821891 size (PDoBlock dos) = 1 + size dos

18831892 size (PIdiom fc term) = 1 + size term

@@ -1889,7 +1898,7 @@ instance Sized PTerm where

18891898 size _ = 0

18901899

18911900getPArity :: PTerm -> Int

1892−getPArity (PPi _ _ _ sc) = 1 + getPArity sc

1901+getPArity (PPi _ _ _ _ sc) = 1 + getPArity sc

18931902getPArity _ = 0

18941903

18951904-- Return all names, free or globally bound, in the given term.

@@ -1904,8 +1913,8 @@ allNamesIn tm = nub $ ni [] tm

19041913 ni env (PAppBind _ f as) = ni env f ++ concatMap (ni env) (map getTm as)

19051914 ni env (PCase _ c os) = ni env c ++ concatMap (ni env) (map snd os)

19061915 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

1908− ni env (PPi p n ty sc) = niTacImp env p ++ ni env ty ++ ni (n:env) sc

1916+ ni env (PLam fc n _ ty sc) = 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

19091918 ni env (PHidden tm) = ni env tm

19101919 ni env (PRewrite _ l r _) = ni env l ++ ni env r

19111920 ni env (PTyped l r) = ni env l ++ ni env r

@@ -1930,9 +1939,9 @@ boundNamesIn tm = S.toList (ni S.empty tm)

19301939 ni set (PAppBind _ f as) = niTms (ni set f) (map getTm as)

19311940 ni set (PCase _ c os) = niTms (ni set c) (map snd os)

19321941 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

1934− ni set (PLet fc n 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

1942+ ni set (PLam fc n _ ty sc) = S.insert n $ ni (ni set ty) sc

1943+ ni set (PLet fc n nfc ty val sc) = S.insert n $ ni (ni (ni set ty) val) sc

1944+ ni set (PPi p n _ ty sc) = niTacImp (S.insert n $ ni (ni set ty) sc) p

19361945 ni set (PRewrite _ l r _) = ni (ni set l) r

19371946 ni set (PTyped l r) = ni (ni set l) r

19381947 ni set (PPair _ _ l r) = ni (ni set l) r

@@ -1970,8 +1979,8 @@ implicitNamesIn uvars ist tm = nub $ ni [] tm

19701979 (nub (concatMap (ni env) (map snd os))

19711980 \\ nub (concatMap (ni env) (map fst os)))

19721981 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

1974− ni env (PPi p 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

1983+ ni env (PPi p n _ ty sc) = ni env ty ++ ni (n:env) sc

19751984 ni env (PRewrite _ l r _) = ni env l ++ ni env r

19761985 ni env (PTyped l r) = ni env l ++ ni env r

19771986 ni env (PPair _ _ l r) = ni env l ++ ni env r

@@ -2000,8 +2009,8 @@ namesIn uvars ist tm = nub $ ni [] tm

20002009 (nub (concatMap (ni env) (map snd os))

20012010 \\ nub (concatMap (ni env) (map fst os)))

20022011 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

2004− ni env (PPi p n ty sc) = niTacImp env p ++ ni env ty ++ ni (n:env) sc

2012+ ni env (PLam fc n nfc ty sc) = 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

20052014 ni env (PRewrite _ l r _) = ni env l ++ ni env r

20062015 ni env (PTyped l r) = ni env l ++ ni env r

20072016 ni env (PPair _ _ l r) = ni env l ++ ni env r

@@ -2031,8 +2040,8 @@ usedNamesIn vars ist tm = nub $ ni [] tm

20312040 ni env (PAppBind _ f as) = ni env f ++ concatMap (ni env) (map getTm as)

20322041 ni env (PCase _ c os) = ni env c ++ concatMap (ni env) (map snd os)

20332042 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

2035− ni env (PPi p n ty sc) = niTacImp env p ++ ni env ty ++ ni (n:env) sc

2043+ ni env (PLam fc n _ ty sc) = 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

20362045 ni env (PRewrite _ l r _) = ni env l ++ ni env r

20372046 ni env (PTyped l r) = ni env l ++ ni env r

20382047 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

345345 return (show fn ++ " " ++ ap ++ "= ?"

346346 ++ show fn ++ "_rhs")

347347 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

349349 = let n = getNameFrom i used ty in

350350 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

352352 | thead n == '_'

353353 = let n = getNameFrom i used ty in

354354 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

356356 = 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

358358 mkApp i _ _ = ""

359359

360− getNameFrom i used (PPi _ _ _ _)

360+ getNameFrom i used (PPi _ _ _ _ _)

361361 = uniqueNameFrom (mkSupply [sUN "f", sUN "g"]) used

362362 getNameFrom i used (PApp fc f as) = getNameFrom i used f

363363 getNameFrom i used (PRef fc f)

@@ -386,7 +386,7 @@ getProofClause :: Int -- ^ line number that the type is declared

386386getProofClause l fn fp

387387 = do ty <- getInternalApp fp l

388388 return (mkApp ty ++ " = ?" ++ show fn ++ "_rhs")

389− where mkApp (PPi _ _ _ sc) = mkApp sc

389+ where mkApp (PPi _ _ _ _ sc) = mkApp sc

390390 mkApp rt = "(" ++ show rt ++ ") <== " ++ show fn

391391

392392-- 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

249249----- Generated by 'derive'

250250

251251instance Binary FC where

252− put (FC x1 (x2, x3) (x4, x5))

253− = do put x1

254− put (x2 * 65536 + x3)

255− put (x4 * 65536 + x5)

252+ put x =

253+ case x of

254+ (FC x1 (x2, x3) (x4, x5)) -> do putWord8 0

255+ put x1

256+ put (x2 * 65536 + x3)

257+ put (x4 * 65536 + x5)

258+ NoFC -> putWord8 1

259+ FileFC x1 -> do putWord8 2

260+ put x1

256261 get

257− = do x1 <- get

258− x2x3 <- get

259− x4x5 <- get

260− return (FC x1 (x2x3 `div` 65536, x2x3 `mod` 65536) (x4x5 `div` 65536, x4x5 `mod` 65536))

262+ = do i <- getWord8

263+ case i of

264+ 0 -> do x1 <- get

265+ x2x3 <- get

266+ x4x5 <- get

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"

261272

262273

263274instance Binary Name where

src/Idris/Core/DeepSeq.hs+2

@@ -43,6 +43,8 @@ instance NFData Raw where

4343

4444instance NFData FC where

4545 rnf (FC x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

46+ rnf NoFC = ()

47+ rnf (FileFC f) = rnf f `seq` ()

4648

4749instance NFData Provenance where

4850 rnf ExpectedType = ()

src/Idris/Core/TT.hs+65−9

@@ -49,11 +49,59 @@ data Option = TTypeInTType

4949 deriving Eq

5050

5151-- | Source location. These are typically produced by the parser 'Idris.Parser.getFC'

52−data FC = FC { fc_fname :: String, -- ^ Filename

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

52+data FC = FC { _fc_fname :: String, -- ^ Filename

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

5555 }

56− deriving (Data, Typeable, Ord)

56+ | NoFC -- ^ Locations for machine-generated terms

57+ | FileFC { _fc_fname :: String } -- ^ Locations with file only

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+

57105

58106-- | Ignore source location equality (so deriving classes do not compare FCs)

59107instance Eq FC where

@@ -65,14 +113,17 @@ newtype FC' = FC' { unwrapFC :: FC }

65113instance Eq FC' where

66114 FC' fc == FC' fc' = fcEq fc fc'

67115 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

68119

69120-- | Empty source location

70121emptyFC :: FC

71−emptyFC = fileFC ""

122+emptyFC = NoFC

72123

73−-- | Source location with file only

124+-- | Source location with file only

74125fileFC :: String -> FC

75−fileFC s = FC s (0, 0) (0, 0)

126+fileFC s = FileFC s

76127

77128{-!

78129deriving instance Binary FC

@@ -81,18 +132,22 @@ deriving instance NFData FC

81132

82133instance Sized FC where

83134 size (FC f s e) = 4 + length f

135+ size NoFC = 1

136+ size (FileFC f) = length f

84137

85138instance Show FC where

86139 show (FC f s e) = f ++ ":" ++ showLC s e

87140 where showLC (sl, sc) (el, ec) | sl == el && sc == ec = show sl ++ ":" ++ show sc

88141 | sl == el = show sl ++ ":" ++ show sc ++ "-" ++ show ec

89142 | otherwise = show sl ++ ":" ++ show sc ++ "-" ++ show el ++ ":" ++ show ec

143+ show NoFC = "No location"

144+ show (FileFC f) = f

90145

91146-- | 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

93148

94149-- | Text formatting output

95−data TextFormatting = BoldText | ItalicText | UnderlineText

150+data TextFormatting = BoldText | ItalicText | UnderlineText deriving Show

96151

97152-- | Output annotations for pretty-printing

98153data OutputAnnotation = AnnName Name (Maybe NameOutput) (Maybe String) (Maybe String)

@@ -108,6 +163,7 @@ data OutputAnnotation = AnnName Name (Maybe NameOutput) (Maybe String) (Maybe St

108163 | AnnTerm [(Name, Bool)] (TT Name) -- ^ pprint bound vars, original term

109164 | AnnSearchResult Ordering -- ^ more general, isomorphic, or more specific

110165 | AnnErr Err

166+ deriving Show

111167

112168-- | Used for error reflection

113169data ErrorReportPart = TextPart String

src/Idris/Coverage.hs+4−4

@@ -179,8 +179,8 @@ genAll i args

179179 where

180180 -- if they're constants, invent a new one to make sure that

181181 -- constants which are not explicitly handled are covered

182− inventConsts cs@(PConstant c : _) = map PConstant (ic' (mapMaybe getConst cs))

183− where getConst (PConstant c) = Just c

182+ inventConsts cs@(PConstant fc c : _) = map (PConstant NoFC) (ic' (mapMaybe getConst cs))

183+ where getConst (PConstant _ c) = Just c

184184 getConst _ = Nothing

185185 inventConsts xs = xs

186186

@@ -226,7 +226,7 @@ genAll i args

226226 ([pimp (sUN "a") Placeholder True,

227227 pimp (sUN "P") Placeholder True] ++

228228 [pexp t,pexp v]) o

229− otherPats o@(PConstant c) = inventConsts [o] -- return o

229+ otherPats o@(PConstant _ c) = inventConsts [o] -- return o

230230 otherPats arg = return Placeholder

231231

232232 ops fc n xs o

@@ -278,7 +278,7 @@ genAll i args

278278

279279 -- quick check for constructor equality

280280 quickEq :: PTerm -> PTerm -> Bool

281− quickEq (PConstant n) (PConstant n') = n == n'

281+ quickEq (PConstant _ n) (PConstant _ n') = n == n'

282282 quickEq (PRef _ n) (PRef _ n') = n == n'

283283 quickEq (PApp _ t as) (PApp _ t' as')

284284 | length as == length as'

src/Idris/DSL.hs+28−28

@@ -33,8 +33,8 @@ mkTTName fc n =

3333 mkList fc (x:xs) = PApp fc (PRef fc (sNS (sUN "::") ["List", "Prelude"]))

3434 [ pexp (stringC x)

3535 , pexp (mkList fc xs)]

36− stringC = PConstant . Str . str

37− intC = PConstant . I

36+ stringC = PConstant fc . Str . str

37+ intC = PConstant fc . I

3838 reflm n = sNS (sUN n) ["Reflection", "Language"]

3939 in case n of

4040 UN nm -> PApp fc (PRef fc (reflm "UN")) [ pexp (stringC nm)]

@@ -45,26 +45,26 @@ mkTTName fc n =

4545 otherwise -> PRef fc $ reflm "NErased"

4646

4747expandSugar :: DSL -> PTerm -> PTerm

48−expandSugar dsl (PLam fc n ty tm)

48+expandSugar dsl (PLam fc n nfc ty tm)

4949 | Just lam <- dsl_lambda dsl

5050 = let sc = PApp fc lam [ pexp (mkTTName fc n)

5151 , pexp (var dsl n tm 0)]

5252 in expandSugar dsl sc

53−expandSugar dsl (PLam fc n ty tm) = PLam fc n (expandSugar dsl ty) (expandSugar dsl tm)

54−expandSugar dsl (PLet fc n ty v 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 nfc ty v tm)

5555 | Just letb <- dsl_let dsl

5656 = let sc = PApp (fileFC "(dsl)") letb [ pexp (mkTTName fc n)

5757 , pexp v

5858 , pexp (var dsl n tm 0)]

5959 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)

61−expandSugar dsl (PPi p n ty 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 fc ty tm)

6262 | Just pi <- dsl_pi dsl

6363 = let sc = PApp (fileFC "(dsl)") pi [ pexp (mkTTName (fileFC "(dsl)") n)

6464 , pexp ty

6565 , pexp (var dsl n tm 0)]

6666 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)

6868expandSugar dsl (PApp fc t args) = PApp fc (expandSugar dsl t)

6969 (map (fmap (expandSugar dsl)) args)

7070expandSugar 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)

7272expandSugar dsl (PCase fc s opts) = PCase fc (expandSugar dsl s)

7373 (map (pmap (expandSugar dsl)) opts)

7474expandSugar 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"))

7676 [ PExp 0 [] (sMN 0 "condition") $ expandSugar dsl c

7777 , PExp 0 [] (sMN 0 "whenTrue") $ expandSugar dsl t

7878 , PExp 0 [] (sMN 0 "whenFalse") $ expandSugar dsl f

@@ -95,20 +95,20 @@ expandSugar dsl (PDoBlock ds)

9595 where

9696 block b [DoExp fc tm] = tm

9797 block b [a] = PElabError (Msg "Last statement in do block must be an expression")

98− block b (DoBind fc n tm : rest)

99− = PApp fc b [pexp tm, pexp (PLam fc n Placeholder (block b rest))]

98+ block b (DoBind fc n nfc tm : rest)

99+ = PApp fc b [pexp tm, pexp (PLam fc n nfc Placeholder (block b rest))]

100100 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

102102 (PCase fc (PRef fc (sMN 0 "bpat"))

103103 ((p, block b rest) : alts)))]

104− block b (DoLet fc n ty tm : rest)

105− = PLet fc n ty tm (block b rest)

104+ block b (DoLet fc n nfc ty tm : rest)

105+ = PLet fc n nfc ty tm (block b rest)

106106 block b (DoLetP fc p tm : rest)

107107 = PCase fc tm [(p, block b rest)]

108108 block b (DoExp fc tm : rest)

109109 = PApp fc b

110110 [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))]

112112 block b _ = PElabError (Msg "Invalid statement in do block")

113113

114114expandSugar 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

122122 case dsl_var dsl of

123123 Nothing -> PElabError (Msg "No 'variable' defined in dsl")

124124 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)

126126 | Nothing <- dsl_lambda dsl

127− = PLam fc n ty (v' i sc)

128− | otherwise = PLam fc n (v' i ty) (v' (i + 1) sc)

129− v' i (PLet fc n ty val sc)

127+ = PLam fc n nfc ty (v' i sc)

128+ | otherwise = PLam fc n nfc (v' i ty) (v' (i + 1) sc)

129+ v' i (PLet fc n nfc ty val sc)

130130 | Nothing <- dsl_let dsl

131− = PLet fc n (v' i ty) (v' i val) (v' i sc)

132− | otherwise = PLet fc n (v' i ty) (v' i val) (v' (i + 1) sc)

133− v' i (PPi p n ty sc)

131+ = PLet fc n nfc (v' i ty) (v' i val) (v' i sc)

132+ | otherwise = PLet fc n nfc (v' i ty) (v' i val) (v' (i + 1) sc)

133+ v' i (PPi p n fc ty sc)

134134 | Nothing <- dsl_pi dsl

135− = PPi p n (v' i ty) (v' i sc)

136− | otherwise = PPi p n (v' i ty) (v' (i+1) sc)

135+ = PPi p n fc (v' i ty) (v' i sc)

136+ | otherwise = PPi p n fc (v' i ty) (v' (i+1) sc)

137137 v' i (PTyped l r) = PTyped (v' i l) (v' i r)

138138 v' i (PApp f x as) = PApp f (v' i x) (fmap (fmap (v' i)) as)

139139 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

187187 = do t' <- db' t

188188 args' <- mapM dbArg args

189189 return (PApp fc t' args')

190− db' (PLam fc n ty sc) = return (PLam fc n ty (debind b sc))

191− db' (PLet fc n ty v sc) = do v' <- db' v

192− return (PLet fc n ty v' (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 nfc ty v sc) = do v' <- db' v

192+ return (PLet fc n nfc ty v' (debind b sc))

193193 db' (PCase fc s opts) = do s' <- db' s

194194 return (PCase fc s' (map (pmap (debind b)) opts))

195195 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

212212

213213 bindAll [] tm = tm

214214 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))]

216216

217217

src/Idris/DeepSeq.hs+33−21

@@ -129,10 +129,12 @@ instance NFData DataOpt where

129129

130130instance (NFData t) => NFData (PDecl' t) where

131131 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)

133133 = rnf x1 `seq`

134134 rnf x2 `seq`

135− rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` rnf x7 `seq` ()

135+ rnf x3 `seq`

136+ rnf x4 `seq`

137+ rnf x5 `seq` rnf x6 `seq` rnf x7 `seq` rnf x8 `seq` ()

136138 rnf (PPostulate x1 x2 x3 x4 x5 x6 x7)

137139 = rnf x1 `seq`

138140 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

145147 rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` ()

146148 rnf (PParams x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

147149 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)

149151 = rnf x1 `seq`

150152 rnf x2 `seq`

151153 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` ()

153− rnf (PClass x1 x2 x3 x4 x5 x6 x8 x7 x9 x10 x11)

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` ()

161+ rnf (PClass x1 x2 x3 x4 x5 x6 x8 x7 x9 x10 x11 x12)

154162 = rnf x1 `seq`

155163 rnf x2 `seq`

156164 rnf x3 `seq`

@@ -159,15 +167,19 @@ instance (NFData t) => NFData (PDecl' t) where

159167 rnf x6 `seq`

160168 rnf x7 `seq`

161169 rnf x8 `seq`

162− rnf x9 `seq` rnf x10 `seq` rnf x11 `seq` ()

163− rnf (PInstance x1 x2 x3 x4 x5 x6 x7 x8 x9 x10)

170+ rnf x9 `seq`

171+ rnf x10 `seq`

172+ rnf x11 `seq` rnf x12 `seq` ()

173+ rnf (PInstance x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11)

164174 = rnf x1 `seq`

165175 rnf x2 `seq`

166176 rnf x3 `seq`

167177 rnf x4 `seq`

168178 rnf x5 `seq`

169179 rnf x6 `seq`

170− rnf x7 `seq` rnf x8 `seq` rnf x9 `seq` rnf x10 `seq` ()

180+ rnf x7 `seq`

181+ rnf x8 `seq`

182+ rnf x9 `seq` rnf x10 `seq` rnf x11 `seq` ()

171183 rnf (PDSL x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

172184 rnf (PSyntax x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

173185 rnf (PMutual x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

@@ -197,20 +209,20 @@ instance (NFData t) => NFData (PClause' t) where

197209 = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` ()

198210

199211instance (NFData t) => NFData (PData' t) where

200− rnf (PDatadecl x1 x2 x3)

201− = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

202− rnf (PLaterdecl x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

212+ rnf (PDatadecl x1 x2 x3 x4)

213+ = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()

214+ rnf (PLaterdecl x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

203215

204216instance NFData PTerm where

205217 rnf (PQuote x1) = rnf x1 `seq` ()

206218 rnf (PRef x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

207219 rnf (PInferRef x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

208220 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` ()

210− rnf (PPi x1 x2 x3 x4)

211− = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()

212− rnf (PLet _ x1 x2 x3 x4)

213− = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()

221+ rnf (PLam _ x1 x2 x3 x4) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()

222+ rnf (PPi x1 x2 x3 x4 x5)

223+ = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` ()

224+ rnf (PLet _ x1 x2 x3 x4 x5)

225+ = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` ()

214226 rnf (PTyped x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

215227 rnf (PAppImpl x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

216228 rnf (PApp x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

@@ -228,11 +240,11 @@ instance NFData PTerm where

228240 rnf (PAs x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

229241 rnf (PAlternative x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

230242 rnf (PHidden x1) = rnf x1 `seq` ()

231− rnf PType = ()

243+ rnf (PType fc) = rnf fc `seq` ()

232244 rnf (PUniverse _) = ()

233245 rnf (PGoal x1 x2 x3 x4)

234246 = 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` ()

236248 rnf Placeholder = ()

237249 rnf (PDoBlock x1) = rnf x1 `seq` ()

238250 rnf (PIdiom x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

@@ -302,10 +314,10 @@ instance NFData ErrorReportPart where

302314

303315instance (NFData t) => NFData (PDo' t) where

304316 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` ()

306318 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)

308− = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()

319+ rnf (DoLet x1 x2 x3 x4 x5)

320+ = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` ()

309321 rnf (DoLetP x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

310322

311323instance (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

6161 Just (Just _, mi, _) -> mkMVApp n []

6262 _ -> PRef un n

6363 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)

6565 de env is (Bind n (Pi (Just impl) ty _) sc)

6666 | 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)

6868 | 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)

7070 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)

7272 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)

7474 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)

7676 de env (plic:is) (Bind n (Pi _ ty _) sc)

7777 = PPi (Exp (argopts plic) Dynamic False)

78− n

78+ n NoFC

7979 (de env [] ty)

8080 (de ((n,n):env) is sc)

8181 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)

8383

8484 de env imps (Bind n (Let ty val) sc)

8585 | isCaseApp sc

8686 , (P _ cOp _, args) <- unApply sc

8787 , Just caseblock <- delabCase env imps n val cOp args = caseblock

8888 | 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)

9090 de env _ (Bind n (Hole ty) sc) = de ((n, sUN "[__]"):env) [] sc

9191 de env _ (Bind n (Guess ty val) sc) = de ((n, sUN "[__]"):env) [] sc

9292 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

9494 de env _ (Proj _ _) = error "Delaboration got run-time-only Proj!"

9595 de env _ Erased = Placeholder

9696 de env _ Impossible = Placeholder

97− de env _ (TType i) = PType

97+ de env _ (TType i) = PType un

9898 de env _ (UType u) = PUniverse u

9999

100100 dens x | fullname = x

@@ -306,7 +306,7 @@ pprintErr' i (InvalidTCArg n t)

306306 <> annName n <$>

307307 text "(Type class arguments must be injective)"

308308pprintErr' 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)))

310310pprintErr' i (NoTypeDecl n) = text "No type declaration for" <+> annName n

311311pprintErr' i (NoSuchVariable n) = text "No such variable" <+> annName n

312312pprintErr' i (WithFnType ty) =

@@ -474,14 +474,14 @@ addImplicitDiffs x y

474474 else (a { getTm = a' } : as',

475475 b { getTm = b' } : bs')

476476 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)

478478 = let (a', c') = addI a c

479479 (b', d') = addI b d in

480− (PLam fc n a' b', PLam fc' n' c' d')

481− addI (PPi p n a b) (PPi p' n' c d)

480+ (PLam fc n nfc a' b', PLam fc' n' nfc' c' d')

481+ addI (PPi p n fc a b) (PPi p' n' fc' c d)

482482 = let (a', c') = addI a c

483483 (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')

485485 addI (PPair fc pi a b) (PPair fc' pi' c d)

486486 = let (a', c') = addI a c

487487 (b', d') = addI b d in

@@ -498,9 +498,9 @@ addImplicitDiffs x y

498498 expLike (PApp _ f as) (PApp _ f' as')

499499 = expLike f f' && length as == length as' &&

500500 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')

502502 = 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')

504504 = n == n' && expLike s s' && expLike t t'

505505 expLike (PPair _ _ x y) (PPair _ _ x' y') = expLike x x' && expLike y y'

506506 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)

525525annTm :: Term -> Doc OutputAnnotation -> Doc OutputAnnotation

526526annTm tm = annotate (AnnTerm [] tm)

527527

528−fancifyAnnots :: IState -> OutputAnnotation -> OutputAnnotation

529−fancifyAnnots ist annot@(AnnName n _ _ _) =

528+-- | Add extra metadata to an output annotation, optionally marking metavariables.

529+fancifyAnnots :: IState -> Bool -> OutputAnnotation -> OutputAnnotation

530+fancifyAnnots ist meta annot@(AnnName n _ _ _) =

530531 do let ctxt = tt_ctxt ist

531532 docs = docOverview ist n

532533 ty = Just (getTy ist n)

@@ -534,7 +535,9 @@ fancifyAnnots ist annot@(AnnName n _ _ _) =

534535 _ | isDConName n ctxt -> AnnName n (Just DataOutput) docs ty

535536 _ | isFnName n ctxt -> AnnName n (Just FunOutput) docs ty

536537 _ | isTConName n ctxt -> AnnName n (Just TypeOutput) docs ty

537− _ | isMetavarName n ist -> AnnName n (Just MetavarOutput) docs ty

538+ _ | isMetavarName n ist -> if meta

539+ then AnnName n (Just MetavarOutput) docs ty

540+ else AnnName n (Just FunOutput) docs ty

538541 _ | isPostulateName n ist -> AnnName n (Just PostulateOutput) docs ty

539542 _ | otherwise -> annot

540543 where docOverview :: IState -> Name -> Maybe String -- pretty-print first paragraph of docs

@@ -552,7 +555,7 @@ fancifyAnnots ist annot@(AnnName n _ _ _) =

552555 getTy ist n = let theTy = pprintPTerm (ppOptionIst ist) [] [] (idris_infixes ist) $

553556 delabTy ist n

554557 in (displayS . renderPretty 1.0 50 $ theTy) ""

555−fancifyAnnots _ annot = annot

558+fancifyAnnots _ _ annot = annot

556559

557560showSc :: IState -> [(Name, Term)] -> Doc OutputAnnotation

558561showSc i [] = empty

src/Idris/Docs.hs+15−15

@@ -170,8 +170,8 @@ pprintDocs ist (ClassDoc n doc meths params instances subclasses superclasses ct

170170 dumpInstance :: PTerm -> Doc OutputAnnotation

171171 dumpInstance = pprintPTerm ppo params' [] infixes

172172

173− prettifySubclasses (PPi (Constraint _ _) _ tm _) = prettifySubclasses tm

174− prettifySubclasses (PPi plcity nm t1 t2) = PPi plcity (safeHead nm pNames) (prettifySubclasses t1) (prettifySubclasses t2)

173+ prettifySubclasses (PPi (Constraint _ _) _ _ tm _) = prettifySubclasses tm

174+ prettifySubclasses (PPi plcity nm fc t1 t2) = PPi plcity (safeHead nm pNames) NoFC (prettifySubclasses t1) (prettifySubclasses t2)

175175 prettifySubclasses (PApp fc ref args) = PApp fc ref $ updateArgs pNames args

176176 prettifySubclasses tm = tm

177177

@@ -185,8 +185,8 @@ pprintDocs ist (ClassDoc n doc meths params instances subclasses superclasses ct

185185 updateRef nm (PRef fc _) = PRef fc nm

186186 updateRef _ pt = pt

187187

188− isSubclass (PPi (Constraint _ _) _ (PApp _ _ args) (PApp _ (PRef _ nm) args')) = nm == n && map getTm args == map getTm args'

189− isSubclass (PPi _ _ _ pt) = isSubclass pt

188+ isSubclass (PPi (Constraint _ _) _ _ (PApp _ _ args) (PApp _ (PRef _ nm) args')) = nm == n && map getTm args == map getTm args'

189+ isSubclass (PPi _ _ _ _ pt) = isSubclass pt

190190 isSubclass _ = False

191191

192192 prettyParameters =

@@ -271,12 +271,12 @@ docClass n ci

271271 namedInst n@(UN _) = Just n

272272 namedInst _ = Nothing

273273

274− getDInst (PInstance _ _ _ _ _ _ _ t _ _) = Just t

275− getDInst _ = Nothing

274+ getDInst (PInstance _ _ _ _ _ _ _ _ t _ _) = Just t

275+ getDInst _ = Nothing

276276

277− isSubclass (PPi (Constraint _ _) _ (PApp _ _ args) (PApp _ (PRef _ nm) args'))

277+ isSubclass (PPi (Constraint _ _) _ _ (PApp _ _ args) (PApp _ (PRef _ nm) args'))

278278 = nm == n && map getTm args == map getTm args'

279− isSubclass (PPi _ _ _ pt)

279+ isSubclass (PPi _ _ _ _ pt)

280280 = isSubclass pt

281281 isSubclass _

282282 = False

@@ -302,18 +302,18 @@ docFun n

302302 funName n = show n

303303

304304getPArgNames :: 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 =

306306 (name, ty, plicity, lookup name ds) : getPArgNames body ds

307307getPArgNames _ _ = []

308308

309309pprintConstDocs :: IState -> Const -> String -> Doc OutputAnnotation

310310pprintConstDocs 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 <+>

312312 pprintPTerm (ppOptionIst ist) [] [] [] (t c) <>

313313 nest 4 (line <> text str)

314314

315− where t (Fl _) = PConstant $ AType ATFloat

316− t (BI _) = PConstant $ AType (ATInt ITBig)

317− t (Str _) = PConstant StrType

318− t (Ch c) = PConstant $ AType (ATInt ITChar)

319− t _ = PType

315+ where t (Fl _) = PConstant NoFC $ AType ATFloat

316+ t (BI _) = PConstant NoFC $ AType (ATInt ITBig)

317+ t (Str _) = PConstant NoFC StrType

318+ t (Ch c) = PConstant NoFC $ AType (ATInt ITChar)

319+ t _ = PType NoFC

src/Idris/Elab/AsPat.hs+1−1

@@ -17,7 +17,7 @@ desugarAs lhs rhs

1717 bindPats :: [(Name, FC, PTerm)] -> PTerm -> PTerm

1818 bindPats [] rhs = rhs

1919 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)

2121

2222collectAs :: PTerm -> State [(Name, FC, PTerm)] PTerm

2323collectAs (PAs fc n tm) = do tm' <- collectAs tm

src/Idris/Elab/Class.hs+68−53

@@ -15,7 +15,7 @@ import Idris.Primitives

1515import Idris.Inliner

1616import Idris.PartialEval

1717import Idris.DeepSeq

18−import Idris.Output (iputStrLn, pshow, iWarn)

18+import Idris.Output (iputStrLn, pshow, iWarn, sendHighlighting)

1919import IRTS.Lang

2020

2121import Idris.Elab.Type

@@ -54,18 +54,22 @@ data MArgTy = IA Name | EA Name | CA deriving Show

5454

5555elabClass :: ElabInfo -> SyntaxInfo -> Docstring (Either Err PTerm) ->

5656 FC -> [(Name, PTerm)] ->

57− Name -> [(Name, PTerm)] -> [(Name, Docstring (Either Err PTerm))] ->

58− [Name] -> [PDecl] ->

59− Maybe Name {- ^ instance ctor name -} ->

57+ Name -> FC -> [(Name, FC, PTerm)] -> [(Name, Docstring (Either Err PTerm))] ->

58+ [(Name, FC)] {- ^ determining params -} ->

59+ [PDecl] {- ^ class body -} ->

60+ Maybe (Name, FC) {- ^ instance ctor name and location -} ->

6061 Docstring (Either Err PTerm) {- ^ instance ctor docs -} ->

6162 Idris ()

62−elabClass info syn_in doc fc constraints tn ps pDocs fds ds mcn cd

63− = do let cn = fromMaybe (SN (InstanceCtorN tn)) mcn

64− let tty = pibind ps PType

63+elabClass info syn_in doc fc constraints tn tnfc ps pDocs fds ds mcn cd

64+ = do let cn = fromMaybe (SN (InstanceCtorN tn)) (fst <$> mcn)

65+ let tty = pibind (map (\(n, _, ty) -> (n, ty)) ps) (PType fc)

6566 let constraint = PApp fc (PRef fc tn)

66− (map (pexp . PRef fc) (map fst ps))

67+ (map (pexp . PRef fc) (map (\(n, _, _) -> n) ps))

6768

68− let syn = syn_in { using = addToUsing (using syn_in) ps }

69+ let syn =

70+ syn_in { using = addToUsing (using syn_in)

71+ [(pn, pt) | (pn, _, pt) <- ps]

72+ }

6973

7074 -- build data declaration

7175 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

7781 defs <- mapM (defdecl (map (\ (x,y,z) -> z) ims) constraint)

7882 (filter clause ds)

7983 let (methods, imethods)

80− = unzip (map (\ ( x,y,z) -> (x, y)) ims)

84+ = unzip (map (\ (x, y, z) -> (x, y)) ims)

8185 let defaults = map (\ (x, (y, z)) -> (x,y)) defs

8286 -- build instance constructor type

83− let cty = impbind ps $ conbind constraints

87+ let cty = impbind [(pn, pt) | (pn, _, pt) <- ps] $ conbind constraints

8488 $ pibind (map (\ (n, ty) -> (nsroot n, ty)) methods)

8589 constraint

86− let cons = [(cd, pDocs ++ mapMaybe memberDocs ds, cn, cty, fc, [])]

87− let ddecl = PDatadecl tn tty cons

90+

91+ let cons = [(cd, pDocs ++ mapMaybe memberDocs ds, cn, NoFC, cty, fc, [])]

92+ let ddecl = PDatadecl tn NoFC tty cons

93+

8894 logLvl 5 $ "Class data " ++ show (showDImp verbosePPOption ddecl)

8995 -- Elaborate the data declaration

9096 elabData info (syn { no_imp = no_imp syn ++ mnames,

9197 imp_methods = mnames }) doc pDocs fc [] ddecl

92− dets <- findDets cn fds

93− addClass tn (CI cn (map nodoc imethods) defaults idecls (map fst ps) [] dets)

98+ dets <- findDets cn (map fst fds)

99+ addClass tn (CI cn (map nodoc imethods) defaults idecls (map (\(n, _, _) -> n) ps) [] dets)

94100

95101 -- for each constraint, build a top level function to chase it

96102 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

106112 -- add the default definitions

107113 mapM_ (rec_elabDecl info EAll info) (concat (map (snd.snd) defs))

108114 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+

109122 where

110− nodoc (n, (_, o, t)) = (n, (o, t))

123+ nodoc (n, (_, _, o, t)) = (n, (o, t))

124+

111125 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))

113127

114128 -- To make sure the type constructor of the class is in the appropriate

115129 -- uniqueness hierarchy

116− chkUniq u@(PUniverse _) PType = u

130+ chkUniq u@(PUniverse _) (PType _) = u

117131 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

119133 chkUniq _ t = t

120134

121135 mdec :: Name -> Name

@@ -125,7 +139,7 @@ elabClass info syn_in doc fc constraints tn ps pDocs fds ds mcn cd

125139

126140 -- TODO: probably should normalise

127141 checkDefaultSuperclassInstance :: PDecl -> Idris ()

128− checkDefaultSuperclassInstance (PInstance _ _ _ fc cs n ps _ _ _)

142+ checkDefaultSuperclassInstance (PInstance _ _ _ fc cs n _ ps _ _ _)

129143 = do when (not $ null cs) . tclift

130144 $ tfail (At fc (Msg $ "Default superclass instances can't have constraints."))

131145 i <- getIState

@@ -137,40 +151,41 @@ elabClass info syn_in doc fc constraints tn ps pDocs fds ds mcn cd

137151

138152 impbind :: [(Name, PTerm)] -> PTerm -> PTerm

139153 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)

141155

142156 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)

144158 conbind [] x = x

145159

146− getMName (PTy _ _ _ _ _ n _) = nsroot n

147− tdecl allmeths (PTy doc _ syn _ o n t)

148− = do t' <- implicit' info syn (map fst ps ++ allmeths) n t

160+ getMName (PTy _ _ _ _ _ n nfc _) = nsroot n

161+ tdecl allmeths (PTy doc _ syn _ o n nfc t)

162+ = do t' <- implicit' info syn (map (\(n, _, _) -> n) ps ++ allmeths) n t

149163 logLvl 2 $ "Method " ++ show n ++ " : " ++ showTmImpls t'

150− return ( (n, (toExp (map fst ps) Exp t')),

151− (n, (doc, o, (toExp (map fst ps)

152− (\ l s p -> Imp l s p Nothing) t'))),

153− (n, (syn, o, t) ) )

164+ return ( (n, (toExp (map (\(pn, _, _) -> pn) ps) Exp t')),

165+ (n, (nfc, doc, o, (toExp (map (\(pn, _, _) -> pn) ps)

166+ (\ l s p -> Imp l s p Nothing) t'))),

167+ (n, (nfc, syn, o, t) ) )

154168 tdecl _ _ = ifail "Not allowed in a class declaration"

155169

156170 -- Create default definitions

157171 defdecl mtys c d@(PClauses fc opts n cs) =

158172 case lookup n mtys of

159− Just (syn, o, ty) -> do let ty' = insertConstraint c ty

160− let ds = map (decorateid defaultdec)

161− [PTy emptyDocstring [] syn fc [] n ty',

162− PClauses fc (o ++ opts) n cs]

163− iLOG (show ds)

164− return (n, ((defaultdec n, ds!!1), ds))

173+ Just (nfc, syn, o, ty) ->

174+ do let ty' = insertConstraint c ty

175+ let ds = map (decorateid defaultdec)

176+ [PTy emptyDocstring [] syn fc [] n nfc ty',

177+ PClauses fc (o ++ opts) n cs]

178+ iLOG (show ds)

179+ return (n, ((defaultdec n, ds!!1), ds))

165180 _ -> ifail $ show n ++ " is not a method"

166181 defdecl _ _ _ = ifail "Can't happen (defdecl)"

167182

168183 defaultdec (UN n) = sUN ("default#" ++ str n)

169184 defaultdec (NS n ns) = NS (defaultdec n) ns

170185

171− tydecl (PTy _ _ _ _ _ _ _) = True

186+ tydecl (PTy _ _ _ _ _ _ _ _) = True

172187 tydecl _ = False

173− instdecl (PInstance _ _ _ _ _ _ _ _ _ _) = True

188+ instdecl (PInstance _ _ _ _ _ _ _ _ _ _ _) = True

174189 instdecl _ = False

175190 clause (PClauses _ _ _ _) = True

176191 clause _ = False

@@ -184,7 +199,7 @@ elabClass info syn_in doc fc constraints tn ps pDocs fds ds mcn cd

184199 let capp = PApp fc (PRef fc cn) (map (pexp . PRef fc) mnames)

185200 let lhs = PApp fc (PRef fc cfn) [pconst capp]

186201 let rhs = PResolveTC (fileFC "HACK")

187− let ty = PPi constraint cnm c con

202+ let ty = PPi constraint cnm NoFC c con

188203 logLvl 2 ("Dictionary constraint: " ++ showTmImpls ty)

189204 logLvl 2 (showTmImpls lhs ++ " = " ++ showTmImpls rhs)

190205 i <- getIState

@@ -197,12 +212,12 @@ elabClass info syn_in doc fc constraints tn ps pDocs fds ds mcn cd

197212 addInstance False conn' cfn

198213 addIBC (IBCInstance False conn' cfn)

199214-- iputStrLn ("Added " ++ show (conn, cfn, ty))

200− return [PTy emptyDocstring [] syn fc [] cfn ty,

215+ return [PTy emptyDocstring [] syn fc [] cfn NoFC ty,

201216 PClauses fc [Dictionary] cfn [PClause fc cfn lhs [] rhs []]]

202217

203218 -- Generate a top level function which looks up a method in a given

204219 -- 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))

206221 = do let ty' = expandMethNS syn (insertConstraint c ty)

207222 let mnames = take (length all) $ map (\x -> sMN x "meth") [0..]

208223 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

213228 logLvl 2 ("Top level type: " ++ showTmImpls ty')

214229 iLOG (show (m, ty', capp, margs))

215230 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',

217232 PClauses fc [Inlinable] m [PClause fc m lhs [] rhs []]]

218233

219− getMArgs (PPi (Imp _ _ _ _) n ty sc) = IA n : getMArgs sc

220− getMArgs (PPi (Exp _ _ _) n ty sc) = EA n : getMArgs sc

221− getMArgs (PPi (Constraint _ _) n ty sc) = CA : getMArgs sc

234+ getMArgs (PPi (Imp _ _ _ _) n _ ty sc) = IA n : getMArgs sc

235+ getMArgs (PPi (Exp _ _ _) n _ ty sc) = EA n : getMArgs sc

236+ getMArgs (PPi (Constraint _ _) n _ ty sc) = CA : getMArgs sc

222237 getMArgs _ = []

223238

224239 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

234249 rhsArgs (CA : xs) ns = pconst (PResolveTC fc) : rhsArgs xs ns

235250 rhsArgs [] _ = []

236251

237− insertConstraint c (PPi p@(Imp _ _ _ _) n ty sc)

238− = PPi p n ty (insertConstraint c sc)

252+ insertConstraint c (PPi p@(Imp _ _ _ _) n fc ty sc)

253+ = PPi p n fc ty (insertConstraint c sc)

239254 insertConstraint c sc = PPi (constraint { pstatic = Static })

240− (sMN 0 "class") c sc

255+ (sMN 0 "class") NoFC c sc

241256

242257 -- 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)

244259 | n `elem` ns = toExp ns e sc

245− | otherwise = PPi (e l s p) n ty (toExp ns e sc)

246− toExp ns e (PPi p n ty sc) = PPi p n ty (toExp ns e sc)

260+ | otherwise = PPi (e l s p) n fc ty (toExp ns e sc)

261+ toExp ns e (PPi p n fc ty sc) = PPi p n fc ty (toExp ns e sc)

247262 toExp ns e sc = sc

248263

249264memberDocs :: 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)

251266memberDocs (PPostulate _ d _ _ _ n _) = Just (basename n, d)

252267memberDocs (PData d _ _ _ _ pdata) = Just (basename $ d_name pdata, d)

253−memberDocs (PRecord d _ _ _ n _ _ _ _ _ _ ) = Just (basename n, d)

254−memberDocs (PClass d _ _ _ n _ _ _ _ _ _) = Just (basename n, d)

268+memberDocs (PRecord d _ _ _ n _ _ _ _ _ _ _ ) = Just (basename n, d)

269+memberDocs (PClass d _ _ _ n _ _ _ _ _ _ _) = Just (basename n, d)

255270memberDocs _ = Nothing

256271

257272

src/Idris/Elab/Clause.hs+30−16

@@ -16,7 +16,7 @@ import Idris.Inliner

1616import Idris.PartialEval

1717import Idris.Transforms

1818import Idris.DeepSeq

19−import Idris.Output (iputStrLn, pshow, iWarn, iRenderResult)

19+import Idris.Output (iputStrLn, pshow, iWarn, iRenderResult, sendHighlighting)

2020import IRTS.Lang

2121

2222import Idris.Elab.AsPat

@@ -374,7 +374,7 @@ elabPE info fc caller r =

374374 logLvl 2 $ show n ++ " transformation rule: " ++

375375 show rhs ++ " ==> " ++ show lhs

376376

377− elabType info defaultSyntax emptyDocstring [] fc opts newnm specTy

377+ elabType info defaultSyntax emptyDocstring [] fc opts newnm NoFC specTy

378378 let def = map (\(lhs, rhs) ->

379379 PClause fc newnm lhs [] rhs [])

380380 (pe_clauses specdecl)

@@ -453,9 +453,10 @@ checkPossible info fc tcgen fname lhs_in

453453 -- if the LHS type checks, it is possible

454454 case elaborate ctxt (idris_datatypes i) (sMN 0 "patLHS") infP initEState

455455 (erun fc (buildTC i info ELHS [] fname (infTerm lhs))) of

456− OK (ElabResult lhs' _ _ ctxt' newDecls, _) ->

456+ OK (ElabResult lhs' _ _ ctxt' newDecls highlights, _) ->

457457 do setContext ctxt'

458458 processTacticDecls info newDecls

459+ sendHighlighting highlights

459460 let lhs_tm = orderPats (getInferTerm lhs')

460461 case recheck ctxt [] (forget lhs_tm) lhs_tm of

461462 OK _ -> return True

@@ -537,7 +538,7 @@ elabClause info opts (cnum, PClause fc fname lhs_in_as withs rhs_in_as wherebloc

537538 logLvl 4 ("Fixed parameters: " ++ show params ++ " from " ++ show lhs_in ++

538539 "\n" ++ show (fn_ty, fn_is))

539540

540− ((ElabResult lhs' dlhs [] ctxt' newDecls, probs, inj), _) <-

541+ ((ElabResult lhs' dlhs [] ctxt' newDecls highlights, probs, inj), _) <-

541542 tclift $ elaborate ctxt (idris_datatypes i) (sMN 0 "patLHS") infP initEState

542543 (do res <- errAt "left hand side of " fname

543544 (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

546547 return (res, probs, inj))

547548 setContext ctxt'

548549 processTacticDecls info newDecls

550+ sendHighlighting highlights

551+

549552 when inf $ addTyInfConstraints fc (map (\(x,y,_,_,_,_,_) -> (x,y)) probs)

550553

551554 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

612615 logLvl 2 $ "RHS: " ++ show (map fst newargs_all) ++ " " ++ showTmImpls rhs

613616 ctxt <- getContext -- new context with where block added

614617 logLvl 5 "STARTING CHECK"

615− ((rhs', defer, is, probs, ctxt', newDecls), _) <-

618+ ((rhs', defer, is, probs, ctxt', newDecls, highlights), _) <-

616619 tclift $ elaborate ctxt (idris_datatypes i) (sMN 0 "patRHS") clhsty initEState

617620 (do pbinds ist lhs_tm

618621 mapM_ setinj (nub (params ++ inj))

619622 setNextName

620− (ElabResult _ _ is ctxt' newDecls) <-

623+ (ElabResult _ _ is ctxt' newDecls highlights) <-

621624 errAt "right hand side of " fname

622625 (erun fc (build i winfo ERHS opts fname rhs))

623626 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

629632 let (tm, ds) = runState (collectDeferred (Just fname)

630633 (map fst $ case_decls aux) ctxt tt) []

631634 probs <- get_probs

632− return (tm, ds, is, probs, ctxt', newDecls))

635+ return (tm, ds, is, probs, ctxt', newDecls, highlights))

633636 setContext ctxt'

634637 processTacticDecls info newDecls

638+ sendHighlighting highlights

639+

635640 when inf $ addTyInfConstraints fc (map (\(x,y,_,_,_,_,_) -> (x,y)) probs)

636641

637642 logLvl 5 "DONE CHECK"

@@ -727,7 +732,7 @@ elabClause info opts (cnum, PClause fc fname lhs_in_as withs rhs_in_as wherebloc

727732-- = NS (UN ('#':show x)) [show cnum, show fname]

728733

729734 sepBlocks bs = sepBlocks' [] bs where

730− sepBlocks' ns (d@(PTy _ _ _ _ _ n t) : bs)

735+ sepBlocks' ns (d@(PTy _ _ _ _ _ n _ t) : bs)

731736 = let (bf, af) = sepBlocks' (n : ns) bs in

732737 (d : bf, af)

733738 sepBlocks' ns (d@(PClauses _ _ n _) : bs)

@@ -774,12 +779,14 @@ elabClause info opts (_, PWith fc fname lhs_in withs wval_in pn_in withblock)

774779 let params = getParamsInType i [] fn_is fn_ty

775780 let lhs = stripLinear i $ stripUnmatchable i $ propagateParams i params fn_ty (addImplPat i lhs_in)

776781 logLvl 2 ("LHS: " ++ show lhs)

777− (ElabResult lhs' dlhs [] ctxt' newDecls, _) <-

782+ (ElabResult lhs' dlhs [] ctxt' newDecls highlights, _) <-

778783 tclift $ elaborate ctxt (idris_datatypes i) (sMN 0 "patLHS") infP initEState

779784 (errAt "left hand side of with in " fname

780785 (erun fc (buildTC i info ELHS opts fname (infTerm lhs))) )

781786 setContext ctxt'

782787 processTacticDecls info newDecls

788+ sendHighlighting highlights

789+

783790 let lhs_tm = orderPats (getInferTerm lhs')

784791 let lhs_ty = getInferType lhs'

785792 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)

791798 let wval = addImplBound i (map fst bargs) wval_in

792799 logLvl 5 ("Checking " ++ showTmImpls wval)

793800 -- Elaborate wval in this context

794− ((wval', defer, is, ctxt', newDecls), _) <-

801+ ((wval', defer, is, ctxt', newDecls, highlights), _) <-

795802 tclift $ elaborate ctxt (idris_datatypes i) (sMN 0 "withRHS")

796803 (bindTyArgs PVTy bargs infP) initEState

797804 (do pbinds i lhs_tm

798805 setNextName

799806 -- 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

801808 (erun fc (build i info ERHS opts fname (infTerm wval)))

802809 erun fc $ psolve lhs_tm

803810 tt <- get_term

804− return (tt, d, is, ctxt', newDecls))

811+ return (tt, d, is, ctxt', newDecls, highlights))

805812 setContext ctxt'

806813 processTacticDecls info newDecls

814+ sendHighlighting highlights

815+

807816 def' <- checkDef fc iderr defer

808817 let def'' = map (\(n, (i, top, t)) -> (n, (i, top, t, False))) def'

809818 addDeferred def''

@@ -828,7 +837,10 @@ elabClause info opts (_, PWith fc fname lhs_in withs wval_in pn_in withblock)

828837

829838 let mpn = case pn_in of

830839 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]

832844

833845 logLvl 10 ("With type " ++ show (getRetTy cwvaltyN) ++

834846 " 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)

889901 logLvl 5 ("New RHS " ++ showTmImpls rhs)

890902 ctxt <- getContext -- New context with block added

891903 i <- getIState

892− ((rhs', defer, is, ctxt', newDecls), _) <-

904+ ((rhs', defer, is, ctxt', newDecls, highlights), _) <-

893905 tclift $ elaborate ctxt (idris_datatypes i) (sMN 0 "wpatRHS") clhsty initEState

894906 (do pbinds i lhs_tm

895907 setNextName

896− (ElabResult _ d is ctxt' newDecls) <- erun fc (build i info ERHS opts fname rhs)

908+ (ElabResult _ d is ctxt' newDecls highlights) <-

909+ erun fc (build i info ERHS opts fname rhs)

897910 psolve lhs_tm

898911 tt <- get_term

899− return (tt, d, is, ctxt', newDecls))

912+ return (tt, d, is, ctxt', newDecls, highlights))

900913 setContext ctxt'

901914 processTacticDecls info newDecls

915+ sendHighlighting highlights

902916

903917 def' <- checkDef fc iderr defer

904918 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

1515import Idris.Inliner

1616import Idris.PartialEval

1717import Idris.DeepSeq

18−import Idris.Output (iputStrLn, pshow, iWarn)

18+import Idris.Output (iputStrLn, pshow, iWarn, sendHighlighting)

1919import IRTS.Lang

2020

2121import Idris.Elab.Type

@@ -51,7 +51,7 @@ import Data.List.Split (splitOn)

5151import Util.Pretty(pretty, text)

5252

5353elabData :: 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)

5555 = do let codata = Codata `elem` opts

5656 iLOG (show (fc, doc))

5757 checkUndefined fc n

@@ -59,8 +59,9 @@ elabData info syn doc argDocs fc opts (PLaterdecl n t_in)

5959

6060 addIBC (IBCDef n)

6161 updateContext (addTyDecl n (TCon 0 0) cty) -- temporary, to check cons

62+ sendHighlighting [(nfc, AnnName n Nothing Nothing Nothing)]

6263

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)

6465 = do let codata = Codata `elem` opts

6566 iLOG (show fc)

6667 undef <- isUndefined fc n

@@ -116,6 +117,11 @@ elabData info syn doc argDocs fc opts (PDatadecl n t_in dcons)

116117 -- create a case function

117118 when (DefaultCaseFun `elem` opts) $

118119 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

119125 where

120126 setDetaggable :: Name -> Idris ()

121127 setDetaggable n = do

@@ -194,7 +200,7 @@ elabData info syn doc argDocs fc opts (PDatadecl n t_in dcons)

194200 | otherwise = count n ts

195201 mParam args (_ : rest) = Nothing : mParam args rest

196202

197− cname (_, _, n, _, _, _) = n

203+ cname (_, _, n, _, _, _, _) = n

198204

199205 -- Abuse of ElabInfo.

200206 -- TODO Contemplate whether the ElabInfo type needs modification.

@@ -212,9 +218,9 @@ elabData info syn doc argDocs fc opts (PDatadecl n t_in dcons)

212218elabCon :: ElabInfo -> SyntaxInfo -> Name -> Bool ->

213219 Type -> -- for unique kind checking

214220 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]) ->

216222 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)

218224 = do checkUndefined fc n

219225 logLvl 2 $ show fc ++ ":Constructor " ++ show n ++ " : " ++ show t_in

220226 (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)

251257 else return ()

252258 tyIs con t = tclift $ tfail (At fc (Elaborating "constructor " con (Msg (show t ++ " is not " ++ show tn))))

253259

254− mkLazy (PPi pl n ty sc)

260+ mkLazy (PPi pl n nfc ty sc)

255261 = let ty' = if getTyName ty

256262 then PApp fc (PRef fc (sUN "Lazy'"))

257263 [pexp (PRef fc (sUN "LazyCodata")),

258264 pexp ty]

259265 else ty in

260− PPi pl n ty' (mkLazy sc)

266+ PPi pl n nfc ty' (mkLazy sc)

261267 mkLazy t = t

262268

263269 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)

266272

267273

268274 getNamePos :: Int -> PTerm -> Name -> Maybe Int

269− getNamePos i (PPi _ n _ sc) x | n == x = Just i

270− | otherwise = getNamePos (i + 1) sc x

275+ getNamePos i (PPi _ n _ _ sc) x | n == x = Just i

276+ | otherwise = getNamePos (i + 1) sc x

271277 getNamePos _ _ _ = Nothing

272278

273279 -- if the constructor is a UniqueType, the datatype must be too

@@ -302,17 +308,17 @@ type EliminatorState = StateT (Map.Map String Int) Idris

302308-- FIXME: Many things have name starting with elim internally since this was the only purpose in the first edition of the function

303309-- rename to caseFun to match updated intend

304310elabCaseFun :: 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])] ->

306312 ElabInfo -> EliminatorState ()

307313elabCaseFun ind paramPos n ty cons info = do

308314 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))

310316 let (cnstrs, _) = splitPi ty

311317 let (splittedTy@(pms, idxs)) = splitPms cnstrs

312318 generalParams <- namePis False pms

313319 motiveIdxs <- namePis False idxs

314320 let motive = mkMotive n paramPos generalParams motiveIdxs

315− consTerms <- mapM (\(c@(_, _, cnm, _, _, _)) -> do

321+ consTerms <- mapM (\(c@(_, _, cnm, _, _, _, _)) -> do

316322 let casefunt = if ind then "elim_" else "case_"

317323 name <- freshName $ casefunt ++ simpleName cnm

318324 consTerm <- extractConsTerm c generalParams

@@ -321,7 +327,7 @@ elabCaseFun ind paramPos n ty cons info = do

321327 let motiveConstr = [(motiveName, expl, motive)]

322328 let scrutinee = (scrutineeName, expl, applyCons n (interlievePos paramPos generalParams scrutineeIdxs 0))

323329 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

325331 let clauseConsElimArgs = map getPiName consTerms

326332 let clauseGeneralArgs' = map getPiName generalParams ++ [motiveName] ++ clauseConsElimArgs

327333 let clauseGeneralArgs = map (\arg -> pexp (PRef elimFC arg)) clauseGeneralArgs'

@@ -353,8 +359,8 @@ elabCaseFun ind paramPos n ty cons info = do

353359 splitPi :: PTerm -> ([(Name, Plicity, PTerm)], PTerm)

354360 splitPi = splitPi' []

355361 where splitPi' :: [(Name, Plicity, PTerm)] -> PTerm -> ([(Name, Plicity, PTerm)], PTerm)

356− splitPi' acc (PPi pl n tyl tyr) = splitPi' ((n, pl, tyl):acc) tyr

357− splitPi' acc t = (reverse acc, t)

362+ splitPi' acc (PPi pl n _ tyl tyr) = splitPi' ((n, pl, tyl):acc) tyr

363+ splitPi' acc t = (reverse acc, t)

358364

359365 splitPms :: [(Name, Plicity, PTerm)] -> ([(Name, Plicity, PTerm)], [(Name, Plicity, PTerm)])

360366 splitPms cnstrs = (map fst pms, map fst idxs)

@@ -377,7 +383,7 @@ elabCaseFun ind paramPos n ty cons info = do

377383 where keyOf :: PTerm -> String

378384 keyOf (PRef _ name) | isLetter (nameStart name) = (toLower $ nameStart name):"__"

379385 keyOf (PApp _ tyf _) = keyOf tyf

380− keyOf PType = "ty__"

386+ keyOf (PType _) = "ty__"

381387 keyOf _ = "carg__"

382388 nameStart :: Name -> Char

383389 nameStart n = nameStart' (simpleName n)

@@ -414,11 +420,11 @@ elabCaseFun ind paramPos n ty cons info = do

414420 mkMotive :: Name -> [Int] -> [(Name, Plicity, PTerm)] -> [(Name, Plicity, PTerm)] -> PTerm

415421 mkMotive n paramPos params indicies =

416422 let scrutineeTy = (scrutineeArgName, expl, applyCons n (interlievePos paramPos params indicies 0))

417− in piConstr (indicies ++ [scrutineeTy]) PType

423+ in piConstr (indicies ++ [scrutineeTy]) (PType elimFC)

418424

419425 piConstr :: [(Name, Plicity, PTerm)] -> PTerm -> PTerm

420426 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)

422428

423429 interlievePos :: [Int] -> [a] -> [a] -> Int -> [a]

424430 interlievePos idxs [] l2 i = l2

@@ -436,9 +442,9 @@ elabCaseFun ind paramPos n ty cons info = do

436442 _ -> cns

437443

438444 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) =

440446 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))

442448 Just i -> (removeParamPis oldParams params tyr)

443449 removeParamPis oldParams params (PRef _ n) =

444450 case findIndex (== n) oldParams of

@@ -488,8 +494,8 @@ elabCaseFun ind paramPos n ty cons info = do

488494 in return $ filter (\(n,_,_) -> not (n `elem` oldParams))implargs

489495 _ -> return implargs

490496

491− extractConsTerm :: (Docstring (Either Err PTerm), [(Name, Docstring (Either Err PTerm))], Name, PTerm, FC, [Name]) -> [(Name, Plicity, PTerm)] -> EliminatorState PTerm

492− extractConsTerm (doc, argDocs, cnm, ty, fc, fs) generalParameters = do

497+ extractConsTerm :: (Docstring (Either Err PTerm), [(Name, Docstring (Either Err PTerm))], Name, FC, PTerm, FC, [Name]) -> [(Name, Plicity, PTerm)] -> EliminatorState PTerm

498+ extractConsTerm (doc, argDocs, cnm, _, ty, fc, fs) generalParameters = do

493499 let cons' = replaceParams paramPos generalParameters ty

494500 let (args, resTy) = splitPi cons'

495501 implidxs <- implicitIndexes (doc, cnm, ty, fc, fs)

@@ -524,8 +530,8 @@ elabCaseFun ind paramPos n ty cons info = do

524530 convertImplPi (PImp {getTm = t, pname = n}) = Just (n, expl, t)

525531 convertImplPi _ = Nothing

526532

527− generateEliminatorClauses :: (Docstring (Either Err PTerm), [(Name, Docstring (Either Err PTerm))], Name, PTerm, FC, [Name]) -> Name -> [PArg] -> [(Name, Plicity, PTerm)] -> EliminatorState PClause

528− generateEliminatorClauses (doc, _, cnm, ty, fc, fs) cnsElim generalArgs generalParameters = do

533+ generateEliminatorClauses :: (Docstring (Either Err PTerm), [(Name, Docstring (Either Err PTerm))], Name, FC, PTerm, FC, [Name]) -> Name -> [PArg] -> [(Name, Plicity, PTerm)] -> EliminatorState PClause

534+ generateEliminatorClauses (doc, _, cnm, _, ty, fc, fs) cnsElim generalArgs generalParameters = do

529535 let cons' = replaceParams paramPos generalParameters ty

530536 let (args, resTy) = splitPi cons'

531537 i <- State.lift getIState

src/Idris/Elab/Instance.hs+22−20

@@ -14,7 +14,7 @@ import Idris.Primitives

1414import Idris.Inliner

1515import Idris.PartialEval

1616import Idris.DeepSeq

17−import Idris.Output (iputStrLn, pshow, iWarn)

17+import Idris.Output (iputStrLn, pshow, iWarn, sendHighlighting)

1818import IRTS.Lang

1919

2020import Idris.Elab.Type

@@ -56,11 +56,12 @@ elabInstance :: ElabInfo -> SyntaxInfo ->

5656 ElabWhat -> -- phase

5757 FC -> [(Name, PTerm)] -> -- constraints

5858 Name -> -- the class

59+ FC -> -- precise location of class name

5960 [PTerm] -> -- class parameters (i.e. instance)

6061 PTerm -> -- full instance type

6162 Maybe Name -> -- explicit name

6263 [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

6465 i <- getIState

6566 (n, ci) <- case lookupCtxtName n (idris_classes i) of

6667 [c] -> return c

@@ -71,7 +72,7 @@ elabInstance info syn doc argDocs what fc cs n ps t expn ds = do

7172 let iname = mkiname n (namespace info) ps expn

7273 let emptyclass = null (class_methods ci)

7374 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

7576 -- if the instance type matches any of the instances we have already,

7677 -- and it's not a named instance, then it's overlapping, so report an error

7778 case expn of

@@ -146,7 +147,7 @@ elabInstance info syn doc argDocs what fc cs n ps t expn ds = do

146147

147148 where

148149 intInst = case ps of

149− [PConstant (AType (ATInt ITNative))] -> True

150+ [PConstant NoFC (AType (ATInt ITNative))] -> True

150151 _ -> False

151152

152153 mkiname n' ns ps' expn' =

@@ -156,10 +157,10 @@ elabInstance info syn doc argDocs what fc cs n ps t expn ds = do

156157 Just m -> sNS (SN (sInstanceN n' (map show ps'))) m

157158 Just nm -> nm

158159

159− substInstance ips pnames (PInstance doc argDocs syn _ cs n ps t expn ds)

160− = PInstance doc argDocs syn fc cs n (map (substMatchesShadow ips pnames) ps) (substMatchesShadow ips pnames t) expn ds

160+ substInstance ips pnames (PInstance doc argDocs syn _ cs n nfc ps t expn ds)

161+ = PInstance doc argDocs syn fc cs n nfc (map (substMatchesShadow ips pnames) ps) (substMatchesShadow ips pnames t) expn ds

161162

162− isOverlapping i (PInstance doc argDocs syn _ _ n ps t expn _)

163+ isOverlapping i (PInstance doc argDocs syn _ _ n nfc ps t expn _)

163164 = case lookupCtxtName n (idris_classes i) of

164165 [(n, ci)] -> let iname = (mkiname n (namespace info) ps expn) in

165166 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

176177 ty' <- implicit info syn iname ty'

177178 let ty = addImpl [] i ty'

178179 ctxt <- getContext

179− (ElabResult tyT _ _ ctxt' newDecls, _) <-

180+ (ElabResult tyT _ _ ctxt' newDecls highlights, _) <-

180181 tclift $ elaborate ctxt (idris_datatypes i) iname (TType (UVal 0)) initEState

181182 (errAt "type of " iname (erun fc (build i info ERHS [] iname ty)))

182183 setContext ctxt'

183184 processTacticDecls info newDecls

185+ sendHighlighting highlights

184186 ctxt <- getContext

185187 (cty, _) <- recheckC fc id [] tyT

186188 let nty = normalise ctxt [] cty

@@ -200,7 +202,7 @@ elabInstance info syn doc argDocs what fc cs n ps t expn ds = do

200202 _ -> Nothing

201203 overlapping t' = tclift $ tfail (At fc (Msg $

202204 "Overlapping instance: " ++ show t' ++ " already defined"))

203− getRetType (PPi _ _ _ sc) = getRetType sc

205+ getRetType (PPi _ _ _ _ sc) = getRetType sc

204206 getRetType t = t

205207

206208 matchArgs i dets x y =

@@ -215,16 +217,16 @@ elabInstance info syn doc argDocs what fc cs n ps t expn ds = do

215217

216218 mkMethApp (n, _, _, ty)

217219 = lamBind 0 ty (papp fc (PRef fc n) (methArgs 0 ty))

218− lamBind i (PPi (Constraint _ _) _ _ sc) sc'

219− = PLam fc (sMN i "meth") Placeholder (lamBind (i+1) sc sc')

220− lamBind i (PPi _ n ty sc) sc'

221− = PLam fc (sMN i "meth") Placeholder (lamBind (i+1) sc sc')

220+ lamBind i (PPi (Constraint _ _) _ _ _ sc) sc'

221+ = PLam fc (sMN i "meth") NoFC Placeholder (lamBind (i+1) sc sc')

222+ lamBind i (PPi _ n _ ty sc) sc'

223+ = PLam fc (sMN i "meth") NoFC Placeholder (lamBind (i+1) sc sc')

222224 lamBind i _ sc = sc

223− methArgs i (PPi (Imp _ _ _ _) n ty sc)

225+ methArgs i (PPi (Imp _ _ _ _) n _ ty sc)

224226 = 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)

226228 = 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)

228230 = PConstraint 0 [] (sMN 0 "marg") (PResolveTC fc) : methArgs (i+1) sc

229231 methArgs i _ = []

230232

@@ -244,16 +246,16 @@ elabInstance info syn doc argDocs what fc cs n ps t expn ds = do

244246 decorate ns iname (UN n) = NS (SN (MethodN (UN n))) ns

245247 decorate ns iname (NS (UN n) s) = NS (SN (MethodN (UN n))) ns

246248

247− mkTyDecl (n, op, t, _)

248− = PTy emptyDocstring [] syn fc op n

249+ mkTyDecl (n, op, t, _)

250+ = PTy emptyDocstring [] syn fc op n NoFC

249251 (mkUniqueNames [] t)

250252

251253 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)

253255 conbind [] x = x

254256

255257 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)

257259 coninsert cs sc = conbind cs sc

258260

259261 -- 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

6666 -- The goal type for a postulate is always Type.

6767 (ty', typ) <- case what of

6868 ProvTerm ty p -> elabVal info ERHS ty

69− ProvPostulate _ -> elabVal info ERHS PType

69+ ProvPostulate _ -> elabVal info ERHS (PType fc)

7070 unless (isTType typ) $

7171 ifail ("Expected a type, got " ++ show ty' ++ " : " ++ show typ)

7272

@@ -93,7 +93,7 @@ elabProvider doc info syn fc what n

9393 Provide tm

9494 | ProvTerm ty _ <- what ->

9595 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

9797 elabClauses info fc [] n [PClause fc n (PApp fc (PRef fc n) []) [] (delab i tm) []]

9898 logLvl 3 $ "Elaborated provider " ++ show n ++ " as: " ++ show tm

9999 | ProvPostulate _ <- what ->

src/Idris/Elab/Record.hs+61−50

@@ -14,7 +14,7 @@ import Idris.Primitives

1414import Idris.Inliner

1515import Idris.PartialEval

1616import Idris.DeepSeq

17−import Idris.Output (iputStrLn, pshow, iWarn)

17+import Idris.Output (iputStrLn, pshow, iWarn, sendHighlighting)

1818import IRTS.Lang

1919

2020import Idris.ParseExpr (tryFullExpr)

@@ -37,37 +37,44 @@ elabRecord :: ElabInfo

3737 -> (Docstring (Either Err PTerm)) -- ^ The documentation for the whole declaration

3838 -> SyntaxInfo -> FC -> DataOpts

3939 -> Name -- ^ The name of the type being defined

40− -> [(Name, Plicity, PTerm)] -- ^ Parameters

40+ -> FC -- ^ The precise source location of the tycon name

41+ -> [(Name, FC, Plicity, PTerm)] -- ^ Parameters

4142 -> [(Name, Docstring (Either Err PTerm))] -- ^ Parameter Docs

42− -> [((Maybe Name), Plicity, PTerm, Maybe (Docstring (Either Err PTerm)))] -- ^ Fields

43− -> Maybe Name -- ^ Constructor Name

43+ -> [(Maybe (Name, FC), Plicity, PTerm, Maybe (Docstring (Either Err PTerm)))] -- ^ Fields

44+ -> Maybe (Name, FC) -- ^ Constructor Name

4445 -> (Docstring (Either Err PTerm)) -- ^ Constructor Doc

4546 -> SyntaxInfo -- ^ Constructor SyntaxInfo

4647 -> 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

4849 = do logLvl 1 $ "Building data declaration for " ++ show tyn

4950 -- Type constructor

5051 let tycon = generateTyConType params

5152 logLvl 1 $ "Type constructor " ++ showTmImpls tycon

5253

5354 -- Data constructor

54− dconName <- generateDConName cname

55+ dconName <- generateDConName (fmap fst cname)

5556 let dconTy = generateDConType params fieldsWithNameAndDoc

5657 logLvl 1 $ "Data constructor: " ++ showTmImpls dconTy

5758

5859 -- Build data declaration for elaboration

5960 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, [])]

6162 elabData info rsyn doc paramDocs fc opts datadecl

6263

6364 iLOG $ "fieldsWithName " ++ show fieldsWithName

6465 iLOG $ "fieldsWIthNameAndDoc " ++ show fieldsWithNameAndDoc

6566 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+

6673 where

6774 -- | Generates a type constructor.

68− generateTyConType :: [(Name, Plicity, PTerm)] -> PTerm

69− generateTyConType ((n, p, t) : rest) = PPi p (nsroot n) t (generateTyConType rest)

70− generateTyConType [] = PType

75+ generateTyConType :: [(Name, FC, Plicity, PTerm)] -> PTerm

76+ generateTyConType ((n, nfc, p, t) : rest) = PPi p (nsroot n) nfc t (generateTyConType rest)

77+ generateTyConType [] = (PType fc)

7178

7279 -- | Generates a name for the data constructor if none was specified.

7380 generateDConName :: Maybe Name -> Idris Name

@@ -81,65 +88,66 @@ elabRecord info doc rsyn fc opts tyn params paramDocs fields cname cdoc csyn

8188 Nothing -> return n

8289

8390 -- | Generates the data constructor type.

84− generateDConType :: [(Name, Plicity, PTerm)] -> [(Name, Plicity, PTerm, a)] -> PTerm

85− generateDConType ((n, _, t) : ps) as = PPi impl (nsroot n) t (generateDConType ps as)

86− generateDConType [] ((n, p, t, _) : as) = PPi p (nsroot n) t (generateDConType [] as)

91+ generateDConType :: [(Name, FC, Plicity, PTerm)] -> [(Name, FC, Plicity, PTerm, a)] -> PTerm

92+ generateDConType ((n, nfc, _, t) : ps) as = PPi impl (nsroot n) NoFC t (generateDConType ps as)

93+ generateDConType [] ((n, _, p, t, _) : as) = PPi p (nsroot n) NoFC t (generateDConType [] as)

8794 generateDConType [] [] = target

8895

8996 -- | The target for the constructor and projection functions. Also the source of the update functions.

9097 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]

9299

93− paramsAndDoc :: [(Name, Plicity, PTerm, Docstring (Either Err PTerm))]

100+ paramsAndDoc :: [(Name, FC, Plicity, PTerm, Docstring (Either Err PTerm))]

94101 paramsAndDoc = pad params paramDocs

95102 where

96− pad :: [(Name, Plicity, PTerm)] -> [(Name, Docstring (Either Err PTerm))] -> [(Name, Plicity, PTerm, Docstring (Either Err PTerm))]

97− pad ((n, p, t) : rest) docs

103+ pad :: [(Name, FC, Plicity, PTerm)] -> [(Name, Docstring (Either Err PTerm))] -> [(Name, FC, Plicity, PTerm, Docstring (Either Err PTerm))]

104+ pad ((n, fc, p, t) : rest) docs

98105 = let d = case lookup n docs of

99106 Just d' -> d

100107 Nothing -> emptyDocstring

101− in (n, p, t, d) : (pad rest docs)

108+ in (n, fc, p, t, d) : (pad rest docs)

102109 pad _ _ = []

103110

104111 dconsArgDocs :: [(Name, Docstring (Either Err PTerm))]

105112 dconsArgDocs = paramDocs ++ (dcad fieldsWithName)

106113 where

107− dcad :: [(Name, Plicity, PTerm, Maybe (Docstring (Either Err PTerm)))] -> [(Name, Docstring (Either Err PTerm))]

108− dcad ((n, _, _, (Just d)) : rest) = ((nsroot n), d) : (dcad rest)

114+ dcad :: [(Name, FC, Plicity, PTerm, Maybe (Docstring (Either Err PTerm)))] -> [(Name, Docstring (Either Err PTerm))]

115+ dcad ((n, _, _, _, (Just d)) : rest) = ((nsroot n), d) : (dcad rest)

109116 dcad (_ : rest) = dcad rest

110117 dcad [] = []

111118

112− fieldsWithName :: [(Name, Plicity, PTerm, Maybe (Docstring (Either Err PTerm)))]

119+ fieldsWithName :: [(Name, FC, Plicity, PTerm, Maybe (Docstring (Either Err PTerm)))]

113120 fieldsWithName = fwn [] fields

114121 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)))]

116123 fwn ns ((n, p, t, d) : rest)

117124 = let nn = case n of

118125 Just n' -> n'

119126 Nothing -> newName ns baseName

120− in (expandNS rsyn $ nn, p, t, d) : (fwn (nn : ns) rest)

127+ withNS = expandNS rsyn (fst nn)

128+ in (withNS, snd nn, p, t, d) : (fwn (fst nn : ns) rest)

121129 fwn _ _ = []

122130

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)

124137

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))]

131139 fieldsWithNameAndDoc = fwnad fieldsWithName

132140 where

133− fwnad :: [(Name, Plicity, PTerm, Maybe (Docstring (Either Err PTerm)))] -> [(Name, Plicity, PTerm, Docstring (Either Err PTerm))]

134− fwnad ((n, p, t, d) : rest)

141+ fwnad :: [(Name, FC, Plicity, PTerm, Maybe (Docstring (Either Err PTerm)))] -> [(Name, FC, Plicity, PTerm, Docstring (Either Err PTerm))]

142+ fwnad ((n, nfc, p, t, d) : rest)

135143 = let doc = fromMaybe emptyDocstring d

136− in (n, p, t, doc) : (fwnad rest)

144+ in (n, nfc, p, t, doc) : (fwnad rest)

137145 fwnad [] = []

138146

139147elabRecordFunctions :: ElabInfo -> SyntaxInfo -> FC

140148 -> Name -- ^ Record type name

141− -> [(Name, Plicity, PTerm, Docstring (Either Err PTerm))] -- ^ Parameters

142− -> [(Name, Plicity, PTerm, Docstring (Either Err PTerm))] -- ^ Fields

149+ -> [(Name, FC, Plicity, PTerm, Docstring (Either Err PTerm))] -- ^ Parameters

150+ -> [(Name, FC, Plicity, PTerm, Docstring (Either Err PTerm))] -- ^ Fields

143151 -> Name -- ^ Constructor Name

144152 -> PTerm -- ^ Target type

145153 -> Idris ()

@@ -149,7 +157,7 @@ elabRecordFunctions info rsyn fc tyn params fields dconName target

149157 iLOG $ "Fields: " ++ show fieldNames

150158 iLOG $ "Params: " ++ show paramNames

151159 -- The elaborated constructor type for the data declaration

152− i <- getIState

160+ i <- getIState

153161 ttConsTy <-

154162 case lookupTyExact dconName (tt_ctxt i) of

155163 Just as -> return as

@@ -164,11 +172,11 @@ elabRecordFunctions info rsyn fc tyn params fields dconName target

164172

165173 -- The parameters for elaboration with their documentation

166174 -- 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]

168−

175+ let paramsForElab = [((nsroot n), (paramName n), impl, t, d) | (n, _, _, t, d) <- params] -- zipParams i params paramDocs]

176+

169177 -- The fields (written by the user) with their documentation.

170− let userFieldsForElab = [((nsroot n), n, p, t, d) | (n, p, t, d) <- fields]

171−

178+ let userFieldsForElab = [((nsroot n), n, p, t, d) | (n, nfc, p, t, d) <- fields]

179+

172180 -- All things we need to elaborate projection functions for, together with a number denoting their position in the constructor.

173181 let projectors = [(n, n', p, t, d, i) | ((n, n', p, t, d), i) <- zip (freeFieldsForElab ++ paramsForElab ++ userFieldsForElab) [0..]]

174182 -- Build and elaborate projection functions

@@ -189,10 +197,10 @@ elabRecordFunctions info rsyn fc tyn params fields dconName target

189197

190198 -- | Root names of all fields in the current record declarations

191199 fieldNames :: [Name]

192− fieldNames = [nsroot n | (n, _, _, _) <- fields]

200+ fieldNames = [nsroot n | (n, _, _, _, _) <- fields]

193201

194202 paramNames :: [Name]

195− paramNames = [nsroot n | (n, _, _, _) <- params]

203+ paramNames = [nsroot n | (n, _, _, _, _) <- params]

196204

197205 isFieldOrParam :: Name -> Bool

198206 isFieldOrParam n = n `elem` (fieldNames ++ paramNames)

@@ -207,7 +215,7 @@ elabRecordFunctions info rsyn fc tyn params fields dconName target

207215 isField' (n, _, _, _, _, _) = isField n

208216

209217 fieldTerms :: [PTerm]

210− fieldTerms = [t | (_, _, t, _) <- fields]

218+ fieldTerms = [t | (_, _, _, t, _) <- fields]

211219

212220 -- Delabs the TT to PTerm

213221 -- This is not good.

@@ -238,7 +246,7 @@ elabRecordFunctions info rsyn fc tyn params fields dconName target

238246 paramName (UN n) = sUN ("param_" ++ str n)

239247 paramName (MN i n) = sMN i ("param_" ++ str n)

240248 paramName (NS n s) = NS (paramName n) s

241− paramName n = n

249+ paramName n = n

242250

243251 -- | Elaborate the projection functions.

244252 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

263271

264272 -- | A map from a field name to the other fields it depends on.

265273 fieldDependencies :: [(Name, [Name])]

266− fieldDependencies = map (uncurry fieldDep) [(n, t) | (n, _, t, _) <- fields ++ params]

267− where

274+ fieldDependencies = map (uncurry fieldDep) [(n, t) | (n, _, _, t, _) <- fields ++ params]

275+ where

268276 fieldDep :: Name -> PTerm -> (Name, [Name])

269277 fieldDep n t = ((nsroot n), paramNames ++ fieldNames `intersect` allNamesIn t)

270278

271279 -- | A list of fields depending on another field.

272280 dependentFields :: [Name]

273281 dependentFields = filter depends fieldNames

274− where

282+ where

275283 depends :: Name -> Bool

276284 depends n = case lookup n fieldDependencies of

277285 Just xs -> not $ null xs

@@ -313,7 +321,8 @@ elabProjection info cname pname plicity projTy pdoc psyn fc targetTy cn phArgs f

313321 where

314322 -- | The type of the projection function.

315323 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

317326

318327 -- | The left hand side of the projection function.

319328 generateLhs :: PTerm

@@ -373,9 +382,11 @@ elabUpdate info cname pname plicity pty pdoc psyn fc sty cn args fnames i option

373382 then logLvl 1 $ "Could not generate update function for " ++ show pname

374383 else tclift $ tfail $ At fc (Elaborating "record update function " pname err)) -}

375384 where

376− -- | The type of the udpate function.

385+ -- | The type of the update function.

377386 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)

379390 where substInput = substMatches [(cname, PRef fc (nsroot pname))]

380391

381392 -- | The "_set" name.

src/Idris/Elab/Term.hs+106−45

@@ -48,6 +48,7 @@ data ElabResult =

4848 -- ^ The potentially extended context from new definitions

4949 , resultTyDecls :: [RDeclInstructions]

5050 -- ^ Meta-info about the new type declarations

51+ , resultHighlighting :: [(FC, OutputAnnotation)]

5152 }

5253

5354

@@ -110,13 +111,14 @@ build ist info emode opts fn tm

110111 when tydecl (do mkPat

111112 update_term liftPats

112113 update_term orderPats)

113− EState is _ impls <- getAux

114+ EState is _ impls highlights <- getAux

114115 tt <- get_term

115116 ctxt <- get_context

116117 let (tm, ds) = runState (collectDeferred (Just fn) (map fst is) ctxt tt) []

117118 log <- getLog

118− if (log /= "") then trace log $ return (ElabResult tm ds (map snd is) ctxt impls)

119− else return (ElabResult tm ds (map snd is) ctxt impls)

119+ if log /= ""

120+ then trace log $ return (ElabResult tm ds (map snd is) ctxt impls highlights)

121+ else return (ElabResult tm ds (map snd is) ctxt impls highlights)

120122 where pattern = emode == ELHS

121123 tydecl = emode == ETyDecl

122124

@@ -152,13 +154,14 @@ buildTC ist info emode opts fn tm

152154 -- unification

153155 when (not (null dots)) $

154156 lift (Error (CantMatch (getInferTerm tm)))

155− EState is _ impls <- getAux

157+ EState is _ impls highlights <- getAux

156158 tt <- get_term

157159 ctxt <- get_context

158160 let (tm, ds) = runState (collectDeferred (Just fn) (map fst is) ctxt tt) []

159161 log <- getLog

160− if (log /= "") then trace log $ return (ElabResult tm ds (map snd is) ctxt impls)

161− else return (ElabResult tm ds (map snd is) ctxt impls)

162+ if (log /= "")

163+ then trace log $ return (ElabResult tm ds (map snd is) ctxt impls highlights)

164+ else return (ElabResult tm ds (map snd is) ctxt impls highlights)

162165 where pattern = emode == ELHS

163166

164167-- return whether arguments of the given constructor name can be

@@ -318,18 +321,23 @@ elab ist info emode opts fn tm

318321 -> PTerm -- ^ The term to elaborate

319322 -> ElabD ()

320323 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")

322328 elab' ina fc (PUniverse u) = do apply (RUType u) []; solve

323329-- elab' (_,_,inty) (PConstant c)

324330-- | constType c && pattern && not reflection && not inty

325331-- = lift $ tfail (Msg "Typecase is not allowed")

326− elab' ina fc tm@(PConstant c)

332+ elab' ina fc tm@(PConstant fc' c)

327333 | pattern && not reflection && not (e_qq ina) && not (e_intype ina)

328334 && isTypeConst c

329335 = lift $ tfail $ Msg ("No explicit types on left hand side: " ++ show tm)

330336 | pattern && not reflection && not (e_qq ina) && e_nomatching ina

331337 = 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)

333341 elab' ina fc (PQuote r) = do fill r; solve

334342 elab' ina _ (PTrue fc _) =

335343 do hnf_compute

@@ -343,13 +351,16 @@ elab ist info emode opts fn tm

343351 elab' ina fc (PResolveTC fc')

344352 = do c <- getNameFrom (sMN 0 "class")

345353 instanceArg c

346− elab' ina _ (PApp fc (PRef _ n) args) | n == eqTy, [Placeholder, Placeholder, l, r] <- map getTm args

354+ -- Elaborate the equality type first homogeneously, then

355+ -- heterogeneously as a fallback

356+ elab' ina _ (PApp fc (PRef _ n) args)

357+ | n == eqTy, [Placeholder, Placeholder, l, r] <- map getTm args

347358 = try (do tyn <- getNameFrom (sMN 0 "aqty")

348359 claim tyn RType

349360 movelast tyn

350361 elab' ina (Just fc) (PApp fc (PRef fc eqTy)

351− [pimp (sUN "A") (PRef fc tyn) True,

352− pimp (sUN "B") (PRef fc tyn) False,

362+ [pimp (sUN "A") (PRef NoFC tyn) True,

363+ pimp (sUN "B") (PRef NoFC tyn) False,

353364 pexp l, pexp r]))

354365 (do atyn <- getNameFrom (sMN 0 "aqty")

355366 btyn <- getNameFrom (sMN 0 "bqty")

@@ -358,8 +369,8 @@ elab ist info emode opts fn tm

358369 claim btyn RType

359370 movelast btyn

360371 elab' ina (Just fc) (PApp fc (PRef fc eqTy)

361− [pimp (sUN "A") (PRef fc atyn) True,

362− pimp (sUN "B") (PRef fc btyn) False,

372+ [pimp (sUN "A") (PRef NoFC atyn) True,

373+ pimp (sUN "B") (PRef NoFC btyn) False,

363374 pexp l, pexp r]))

364375

365376 elab' ina _ (PPair fc _ l r)

@@ -402,7 +413,11 @@ elab ist info emode opts fn tm

402413 _ -> asType

403414 where asType = elab' ina (Just fc) (PApp fc (PRef fc sigmaTy)

404415 [pexp t,

405− pexp (PLam fc n Placeholder r)])

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.

420+ pexp (PLam fc n NoFC Placeholder r)])

406421 asValue = elab' ina (Just fc) (PApp fc (PRef fc sigmaCon)

407422 [pimp (sMN 0 "a") t False,

408423 pimp (sMN 0 "P") Placeholder True,

@@ -411,7 +426,7 @@ elab ist info emode opts fn tm

411426 [pimp (sMN 0 "a") t False,

412427 pimp (sMN 0 "P") Placeholder True,

413428 pexp l, pexp r])

414− elab' ina fc (PAlternative True as)

429+ elab' ina fc (PAlternative True as)

415430 = do hnf_compute

416431 ty <- goal

417432 ctxt <- get_context

@@ -436,7 +451,10 @@ elab ist info emode opts fn tm

436451 trySeq' deferr (x : xs)

437452 = try' (do elab' ina fc x

438453 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)

440458-- elab' (_, _, inty) (PRef fc f)

441459-- | isTConName f (tt_ctxt ist) && pattern && not reflection && not inty

442460-- = lift $ tfail (Msg "Typecase is not allowed")

@@ -451,39 +469,56 @@ elab ist info emode opts fn tm

451469 guarded = e_guarded ec

452470 inty = e_intype ec

453471 ctxt <- get_context

472+

454473 let defined = case lookupTy n ctxt of

455474 [] -> False

456475 _ -> True

457476 -- this is to stop us resolve type classes recursively

458477 -- trace (show (n, guarded)) $

459− if (tcname n && ina) then erun fc $ do patvar n; update_term liftPats

478+ if (tcname n && ina)

479+ then erun fc $

480+ do patvar n

481+ update_term liftPats

482+ highlightSource fc (AnnBoundName n False)

460483 else if (defined && not guarded)

461− then do apply (Var n) []; solve

462− else try (do apply (Var n) []; solve)

463− (do patvar n; update_term liftPats)

484+ then do apply (Var n) []

485+ annot <- findHighlight n

486+ solve

487+ highlightSource fc annot

488+ else try (do apply (Var n) []

489+ annot <- findHighlight n

490+ solve

491+ highlightSource fc annot)

492+ (do patvar n

493+ update_term liftPats

494+ highlightSource fc (AnnBoundName n False))

464495 where inparamBlock n = case lookupCtxtName n (inblock info) of

465496 [] -> False

466497 _ -> True

467498 bindable (NS _ _) = False

468499 bindable (UN xs) = True

469500 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 [])

471502 elab' ina fc' tm@(PRef fc n)

472503 | pattern && not reflection && not (e_qq ina) && not (e_intype ina)

473504 && isTConName n (tt_ctxt ist)

474505 = lift $ tfail $ Msg ("No explicit types on left hand side: " ++ show tm)

475506 | pattern && not reflection && not (e_qq ina) && e_nomatching ina

476507 = lift $ tfail $ Msg ("Attempting concrete match on polymorphic argument: " ++ show tm)

477− | otherwise =

508+ | otherwise =

478509 do fty <- get_type (Var n) -- check for implicits

479510 ctxt <- get_context

480− env <- get_env

511+ env <- get_env

481512 let a' = insertScopedImps fc (normalise ctxt env fty) []

482513 if null a'

483− then erun fc $ do apply (Var n) []; solve

514+ then erun fc $

515+ do apply (Var n) []

516+ hl <- findHighlight n

517+ solve

518+ highlightSource fc hl

484519 else elab' ina fc' (PApp fc tm [])

485− elab' ina _ (PLam _ _ _ PImpossible) = lift . tfail . Msg $ "Only pattern-matching lambdas can be impossible"

486− elab' ina _ (PLam fc n Placeholder sc)

520+ elab' ina _ (PLam _ _ _ _ PImpossible) = lift . tfail . Msg $ "Only pattern-matching lambdas can be impossible"

521+ elab' ina _ (PLam fc n nfc Placeholder sc)

487522 = do -- if n is a type constructor name, this makes no sense...

488523 ctxt <- get_context

489524 when (isTConName n ctxt) $

@@ -492,7 +527,8 @@ elab ist info emode opts fn tm

492527 attack; intro (Just n);

493528 -- trace ("------ intro " ++ show n ++ " ---- \n" ++ show ptm)

494529 elabE (ina { e_inarg = True } ) (Just fc) sc; solve

495− elab' ec _ (PLam fc n ty sc)

530+ highlightSource nfc (AnnBoundName n False)

531+ elab' ec _ (PLam fc n nfc ty sc)

496532 = do tyn <- getNameFrom (sMN 0 "lamty")

497533 -- if n is a type constructor name, this makes no sense...

498534 ctxt <- get_context

@@ -510,11 +546,13 @@ elab ist info emode opts fn tm

510546 elabE (ec { e_inarg = True, e_intype = True }) (Just fc) ty

511547 elabE (ec { e_inarg = True }) (Just fc) sc

512548 solve

513− elab' ina fc (PPi p n Placeholder sc)

514− = do attack; arg n (is_scoped p) (sMN 0 "ty")

549+ highlightSource nfc (AnnBoundName n False)

550+ elab' ina fc (PPi p n nfc Placeholder sc)

551+ = do attack; arg n (is_scoped p) (sMN 0 "ty")

515552 elabE (ina { e_inarg = True, e_intype = True }) fc sc

516553 solve

517− elab' ina fc (PPi p n ty sc)

554+ highlightSource nfc (AnnBoundName n False)

555+ elab' ina fc (PPi p n nfc ty sc)

518556 = do attack; tyn <- getNameFrom (sMN 0 "ty")

519557 claim tyn RType

520558 n' <- case n of

@@ -526,7 +564,8 @@ elab ist info emode opts fn tm

526564 elabE ec' fc ty

527565 elabE ec' fc sc

528566 solve

529− elab' ina _ (PLet fc n ty val sc)

567+ highlightSource nfc (AnnBoundName n False)

568+ elab' ina _ (PLet fc n nfc ty val sc)

530569 = do attack

531570 ivs <- get_instances

532571 tyn <- getNameFrom (sMN 0 "letty")

@@ -562,6 +601,7 @@ elab ist info emode opts fn tm

562601 Just (Let t v) -> v

563602 other -> error ("Value not a let binding: " ++ show other))

564603 solve

604+ highlightSource nfc (AnnBoundName n False)

565605 elab' ina _ (PGoal fc r n sc) = do

566606 rty <- goal

567607 attack

@@ -633,7 +673,7 @@ elab ist info emode opts fn tm

633673 solve

634674 -- if f is local, just do a simple_app

635675 -- 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)

637677 | pattern && not reflection && not (e_qq ina) && e_nomatching ina

638678 = lift $ tfail $ Msg ("Attempting concrete match on polymorphic argument: " ++ show tm)

639679 | otherwise = implicitApp $

@@ -641,6 +681,7 @@ elab ist info emode opts fn tm

641681 ty <- goal

642682 fty <- get_type (Var f)

643683 ctxt <- get_context

684+ annot <- findHighlight f

644685 let args = insertScopedImps fc (normalise ctxt env fty) args_in

645686 let unmatchableArgs = if pattern

646687 then getUnmatchable (tt_ctxt ist) f

@@ -651,11 +692,12 @@ elab ist info emode opts fn tm

651692 lift $ tfail $ Msg ("No explicit types on left hand side: " ++ show tm)

652693 if (f `elem` map fst env && length args == 1 && length args_in == 1)

653694 then -- simple app, as below

654− do simple_app False

655− (elabE (ina { e_isfn = True }) (Just fc) (PRef fc f))

695+ do simple_app False

696+ (elabE (ina { e_isfn = True }) (Just fc) (PRef ffc f))

656697 (elabE (ina { e_inarg = True }) (Just fc) (getTm (head args)))

657698 (show tm)

658699 solve

700+ highlightSource ffc annot

659701 return []

660702 else

661703 do ivs <- get_instances

@@ -682,8 +724,12 @@ elab ist info emode opts fn tm

682724 let (ns', eargs) = unzip $

683725 sortBy cmpArg (zip ns args)

684726 ulog <- getUnifyLog

727+

728+ annot <- findHighlight f

729+ highlightSource ffc annot

730+

685731 elabArgs ist (ina { e_inarg = e_inarg ina || not isinf })

686− [] fc False f

732+ [] fc False f

687733 (zip ns' (unmatchableArgs ++ repeat False))

688734 (f == sUN "Force")

689735 (map (\x -> getTm x) eargs) -- TODO: remove this False arg

@@ -755,7 +801,7 @@ elab ist info emode opts fn tm

755801 PAlternative False _ -> 5

756802 PAlternative True _ -> 2

757803 PTactics _ -> 150

758− PLam _ _ _ _ -> 3

804+ PLam _ _ _ _ _ -> 3

759805 PRewrite _ _ _ _ -> 4

760806 PResolveTC _ -> 0

761807 PHidden _ -> 150

@@ -815,10 +861,10 @@ elab ist info emode opts fn tm

815861 setInjective (PApp _ (PRef _ n) _) = setinj n

816862 setInjective _ = return ()

817863

818− elab' ina _ tm@(PApp fc f [arg]) =

864+ elab' ina _ tm@(PApp fc f [arg]) =

819865 erun fc $

820866 do simple_app (not $ headRef f)

821− (elabE (ina { e_isfn = True }) (Just fc) f)

867+ (elabE (ina { e_isfn = True }) (Just fc) f)

822868 (elabE (ina { e_inarg = True }) (Just fc) (getTm arg))

823869 (show tm)

824870 solve

@@ -1035,9 +1081,12 @@ elab ist info emode opts fn tm

10351081 end_unify

10361082

10371083 -- 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

10391085 env <- get_env

1086+ EState _ _ _ hs <- getAux

10401087 loadState

1088+ updateAux (\aux -> aux { highlighting = hs })

1089+

10411090 let quoted = fmap (explicitNames . binderVal) $ lookup nTm env

10421091 isRaw = case unApply (normaliseAll ctxt env finalTy) of

10431092 (P _ n _, []) | n == reflm "Raw" -> True

@@ -1216,9 +1265,9 @@ elab ist info emode opts fn tm

12161265 do impn <- unique_hole (sMN 0 "imp")

12171266 if e_isfn ina -- apply to an implicit immediately

12181267 then return (PApp emptyFC

1219− (PLam emptyFC impn Placeholder t)

1268+ (PLam emptyFC impn NoFC Placeholder t)

12201269 [pexp Placeholder])

1221− else return (PLam emptyFC impn Placeholder t)

1270+ else return (PLam emptyFC impn NoFC Placeholder t)

12221271 addLam _ t = return t

12231272

12241273 insertCoerce ina t@(PCase _ _ _) = return t

@@ -1255,7 +1304,7 @@ elab ist info emode opts fn tm

12551304 elabArgs ist ina failed fc retry f [] force _ = return ()

12561305 elabArgs ist ina failed fc r f (((argName, holeName), unm):ns) force (t : args)

12571306 = do hs <- get_holes

1258− if holeName `elem` hs then

1307+ if holeName `elem` hs then

12591308 do focus holeName

12601309 case t of

12611310 Placeholder -> do movelast holeName

@@ -1352,7 +1401,7 @@ pruneByType env (P _ n _) ctxt as

13521401 where

13531402 headIs var f (PApp _ (PRef _ f') _) = typeHead var f f'

13541403 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

13561405 headIs var f (PHidden t) = headIs var f t

13571406 headIs _ _ _ = True -- keep if it's not an application

13581407

@@ -1370,6 +1419,18 @@ pruneByType env (P _ n _) ctxt as

13701419

13711420pruneByType _ t _ as = as

13721421

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+

13731434findInstances :: IState -> Term -> [Name]

13741435findInstances ist t

13751436 | (P _ n _, _) <- unApply (getRetTy t)

@@ -2265,7 +2326,7 @@ processTacticDecls info steps =

22652326 let tcgen = False -- TODO: later we may support dictionary generation

22662327 case elaborate ctxt (idris_datatypes ist) (sMN 0 "refPatLHS") infP initEState

22672328 (erun fc (buildTC ist info ELHS [] fname (infTerm lhs))) of

2268− OK (ElabResult lhs' _ _ _ _, _) ->

2329+ OK (ElabResult lhs' _ _ _ _ _, _) ->

22692330 do -- not recursively calling here, because we don't

22702331 -- want to run infinitely many times

22712332 let lhs_tm = orderPats (getInferTerm lhs')

src/Idris/Elab/Transform.hs+5−3

@@ -14,7 +14,7 @@ import Idris.Primitives

1414import Idris.Inliner

1515import Idris.PartialEval

1616import Idris.DeepSeq

17−import Idris.Output (iputStrLn, pshow, iWarn)

17+import Idris.Output (iputStrLn, pshow, iWarn, sendHighlighting)

1818import IRTS.Lang

1919

2020import Idris.Elab.Utils

@@ -53,12 +53,13 @@ elabTransform info fc safe lhs_in@(PApp _ (PRef _ tf) _) rhs_in

5353 = do ctxt <- getContext

5454 i <- getIState

5555 let lhs = addImplPat i lhs_in

56− (ElabResult lhs' dlhs [] ctxt' newDecls, _) <-

56+ (ElabResult lhs' dlhs [] ctxt' newDecls highlights, _) <-

5757 tclift $ elaborate ctxt (idris_datatypes i) (sMN 0 "transLHS") infP initEState

5858 (erun fc (buildTC i info ELHS [] (sUN "transform")

5959 (infTerm lhs)))

6060 setContext ctxt'

6161 processTacticDecls info newDecls

62+ sendHighlighting highlights

6263 let lhs_tm = orderPats (getInferTerm lhs')

6364 let lhs_ty = getInferType lhs'

6465 let newargs = pvars i lhs_tm

@@ -72,13 +73,14 @@ elabTransform info fc safe lhs_in@(PApp _ (PRef _ tf) _) rhs_in

7273 tclift $ elaborate ctxt (idris_datatypes i) (sMN 0 "transRHS") clhs_ty initEState

7374 (do pbinds i lhs_tm

7475 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)

7677 erun fc $ psolve lhs_tm

7778 tt <- get_term

7879 let (rhs', defer) = runState (collectDeferred Nothing [] ctxt tt) []

7980 return (rhs', defer, ctxt', newDecls))

8081 setContext ctxt'

8182 processTacticDecls info newDecls

83+ sendHighlighting highlights

8284

8385 (crhs_tm_in, crhs_ty) <- recheckC fc id [] rhs'

8486 let crhs_tm = renamepats pnames crhs_tm_in

src/Idris/Elab/Type.hs+14−9

@@ -16,7 +16,7 @@ import Idris.Primitives

1616import Idris.Inliner

1717import Idris.PartialEval

1818import Idris.DeepSeq

19−import Idris.Output (iputStrLn, pshow, iWarn)

19+import Idris.Output (iputStrLn, pshow, iWarn, sendHighlighting)

2020import IRTS.Lang

2121

2222import Idris.Elab.Utils

@@ -66,11 +66,12 @@ buildType info syn fc opts n ty' = do

6666 logLvl 5 $ show n ++ " type pre-addimpl " ++ showTmImpls ty'

6767 logLvl 2 $ show n ++ " type " ++ show (using syn) ++ "\n" ++ showTmImpls ty

6868

69− (ElabResult tyT' defer is ctxt' newDecls, log) <-

69+ (ElabResult tyT' defer is ctxt' newDecls highlights, log) <-

7070 tclift $ elaborate ctxt (idris_datatypes i) n (TType (UVal 0)) initEState

7171 (errAt "type of " n (erun fc (build i info ETyDecl [] n ty)))

7272 setContext ctxt'

7373 processTacticDecls info newDecls

74+ sendHighlighting highlights

7475

7576 let tyT = patToImp tyT'

7677

@@ -120,14 +121,16 @@ buildType info syn fc opts n ty' = do

120121-- | Elaborate a top-level type declaration - for example, "foo : Int -> Int".

121122elabType :: ElabInfo -> SyntaxInfo

122123 -> Docstring (Either Err PTerm) -> [(Name, Docstring (Either Err PTerm))]

123− -> FC -> FnOpts -> Name -> PTerm -> Idris Type

124+ -> FC -> FnOpts

125+ -> Name -> FC -- ^ The precise location of the name

126+ -> PTerm -> Idris Type

124127elabType = elabType' False

125128

126129elabType' :: Bool -> -- normalise it

127130 ElabInfo -> SyntaxInfo ->

128131 Docstring (Either Err PTerm) -> [(Name, Docstring (Either Err PTerm))] ->

129− FC -> FnOpts -> Name -> PTerm -> Idris Type

130−elabType' norm info syn doc argDocs fc opts n ty' = {- let ty' = piBind (params info) ty_in

132+ FC -> FnOpts -> Name -> FC -> PTerm -> Idris Type

133+elabType' norm info syn doc argDocs fc opts n nfc ty' = {- let ty' = piBind (params info) ty_in

131134 n = liftname info n_in in -}

132135 do checkUndefined fc n

133136 (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

192195 addIBC (IBCErrorHandler n)

193196 else ifail $ "The type " ++ show nty' ++ " is invalid for an error handler"

194197 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)]

195200 -- if it's an export list type, make a note of it

196201 case (unApply usety) of

197202 (P _ ut _, _)

@@ -203,8 +208,8 @@ elabType' norm info syn doc argDocs fc opts n ty' = {- let ty' = piBind (params

203208 -- for making an internalapp, we only want the explicit ones, and don't

204209 -- want the parameters, so just take the arguments which correspond to the

205210 -- user declared explicit ones

206− mergeTy (PPi e n ty sc) (PPi e' n' _ sc')

207− | e == e' = PPi e n ty (mergeTy sc sc')

211+ mergeTy (PPi e n fc ty sc) (PPi e' n' _ _ sc')

212+ | e == e' = PPi e n fc ty (mergeTy sc sc')

208213 | otherwise = mergeTy sc sc'

209214 mergeTy _ sc = sc

210215

@@ -229,7 +234,7 @@ elabType' norm info syn doc argDocs fc opts n ty' = {- let ty' = piBind (params

229234elabPostulate :: ElabInfo -> SyntaxInfo -> Docstring (Either Err PTerm) ->

230235 FC -> FnOpts -> Name -> PTerm -> Idris ()

231236elabPostulate 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

233238 putIState . (\ist -> ist{ idris_postulates = S.insert n (idris_postulates ist) }) =<< getIState

234239 addIBC (IBCPostulate n)

235240

@@ -239,7 +244,7 @@ elabPostulate info syn doc fc opts n ty = do

239244elabExtern :: ElabInfo -> SyntaxInfo -> Docstring (Either Err PTerm) ->

240245 FC -> FnOpts -> Name -> PTerm -> Idris ()

241246elabExtern 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

243248 ist <- getIState

244249 let arity = length (getArgTys (normalise (tt_ctxt ist) [] cty))

245250

src/Idris/Elab/Utils.hs+9−9

@@ -66,9 +66,9 @@ inaccessibleImps _ _ _ = []

6666

6767-- | Get the list of (index, name) of inaccessible arguments from the type.

6868inaccessibleArgs :: Int -> PTerm -> [(Int, Name)]

69−inaccessibleArgs i (PPi (Imp _ _ _ _) n Placeholder t)

69+inaccessibleArgs i (PPi (Imp _ _ _ _) n _ Placeholder t)

7070 = (i,n) : inaccessibleArgs (i+1) t -- unbound implicit

71−inaccessibleArgs i (PPi plicity n ty t)

71+inaccessibleArgs i (PPi plicity n _ ty t)

7272 | InaccessibleArg `elem` pargopts plicity

7373 = (i,n) : inaccessibleArgs (i+1) t -- an .{erased : Implicit}

7474 | otherwise

@@ -117,14 +117,14 @@ inferredDiff fc inf user =

117117-- found, or it will give spurious errors.

118118checkDocs :: FC -> [(Name, Docstring a)] -> PTerm -> Idris ()

119119checkDocs 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

121121 cd as _ | Map.null as = return ()

122122 | otherwise = ierror . At fc . Msg $

123123 "There is documentation for argument(s) "

124124 ++ (concat . intersperse ", " . map show . Map.keys) as

125125 ++ " but they were not found."

126126

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

128128decorateid decorate (PClauses f o n cs)

129129 = PClauses f o (decorate n) (map dc cs)

130130 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)

272272getStatics _ _ = []

273273

274274mkStatic :: [Name] -> PDecl -> PDecl

275−mkStatic ns (PTy doc argdocs syn fc o n ty)

276− = PTy doc argdocs syn fc o n (mkStaticTy ns ty)

275+mkStatic ns (PTy doc argdocs syn fc o n nfc ty)

276+ = PTy doc argdocs syn fc o n nfc (mkStaticTy ns ty)

277277mkStatic ns t = t

278278

279279mkStaticTy :: [Name] -> PTerm -> PTerm

280−mkStaticTy ns (PPi p n ty sc)

281− | n `elem` ns = PPi (p { pstatic = Static }) n ty (mkStaticTy ns sc)

282− | otherwise = PPi p n ty (mkStaticTy ns sc)

280+mkStaticTy ns (PPi p n fc ty sc)

281+ | n `elem` ns = PPi (p { pstatic = Static }) n fc ty (mkStaticTy ns sc)

282+ | otherwise = PPi p n fc ty (mkStaticTy ns sc)

283283mkStaticTy ns t = t

284284

285285

src/Idris/Elab/Value.hs+7−6

@@ -15,7 +15,7 @@ import Idris.Primitives

1515import Idris.Inliner

1616import Idris.PartialEval

1717import Idris.DeepSeq

18−import Idris.Output (iputStrLn, pshow, iWarn)

18+import Idris.Output (iputStrLn, pshow, iWarn, sendHighlighting)

1919import IRTS.Lang

2020

2121import Idris.Elab.Utils

@@ -63,13 +63,14 @@ elabValBind info aspat norm tm_in

6363 -- * elaboration as a Type

6464 -- * elaboration as a function a -> b

6565

66− (ElabResult tm' defer is ctxt' newDecls, _) <-

66+ (ElabResult tm' defer is ctxt' newDecls highlights, _) <-

6767 tclift (elaborate ctxt (idris_datatypes i) (sMN 0 "val") infP initEState

6868 (build i info aspat [Reflection] (sMN 0 "val") (infTerm tm)))

6969

7070 -- Extend the context with new definitions created

7171 setContext ctxt'

7272 processTacticDecls info newDecls

73+ sendHighlighting highlights

7374

7475 let vtm = orderPats (getInferTerm tm')

7576

@@ -118,14 +119,14 @@ elabDocTerms info str = do typechecked <- Traversable.mapM decorate str

118119-- Try running the term directly (as IO ()), then printing it as an Integer

119120-- (as a default numeric tye), then printing it as any Showable thing

120121elabExec :: FC -> PTerm -> PTerm

121−elabExec fc tm = runtm (PAlternative False

122+elabExec fc tm = runtm (PAlternative False

122123 [printtm (PApp fc (PRef fc (sUN "the"))

123− [pexp (PConstant (AType (ATInt ITBig))), pexp tm]),

124+ [pexp (PConstant NoFC (AType (ATInt ITBig))), pexp tm]),

124125 tm,

125126 printtm tm

126127 ])

127− where

128+ where

128129 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"))

130131 [pimp (sUN "ffi") (PRef fc (sUN "FFI_C")) False, pexp t]

131132

src/Idris/ElabDecls.hs+9−9

@@ -156,10 +156,10 @@ elabDecl' _ info (PFix _ _ _)

156156 = return () -- nothing to elaborate

157157elabDecl' _ info (PSyntax _ p)

158158 = 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)

160160 | what /= EDefns

161161 = 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

163163 return ()

164164elabDecl' what info (PPostulate b doc s f o n ty)

165165 | what /= EDefns

@@ -173,7 +173,7 @@ elabDecl' what info (PData doc argDocs s f co d)

173173 elabData info s doc argDocs f co d

174174 | otherwise

175175 = 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))

177177elabDecl' what info d@(PClauses f o n ps)

178178 | what /= ETypes

179179 = do iLOG $ "Elaborating clause " ++ show n

@@ -232,17 +232,17 @@ elabDecl' what info (PNamespace n ps) = mapM_ (elabDecl' what ninfo) ps

232232 ninfo = case namespace info of

233233 Nothing -> info { namespace = Just [n] }

234234 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)

236236 | what /= EDefns

237237 = do iLOG $ "Elaborating class " ++ show n

238− elabClass info (s { syn_params = [] }) doc f cs n ps pdocs fds ds cn cd

239−elabDecl' what info (PInstance doc argDocs s f cs n ps t expn ds)

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 nfc ps t expn ds)

240240 = do iLOG $ "Elaborating instance " ++ show n

241− elabInstance info s doc argDocs what f cs n ps t expn ds

242−elabDecl' what info (PRecord doc rsyn fc opts name ps pdocs fs cname cdoc csyn)

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 nfc ps pdocs fs cname cdoc csyn)

243243 | what /= ETypes

244244 = 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

246246{-

247247 | otherwise

248248 = 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)])

5858extractDoUnquotes d (DoExp fc tm)

5959 = do (tm', ex) <- extractUnquotes d tm

6060 return (DoExp fc tm', ex)

61−extractDoUnquotes d (DoBind fc n tm)

61+extractDoUnquotes d (DoBind fc n nfc tm)

6262 = do (tm', ex) <- extractUnquotes d tm

63− return (DoBind fc n tm', ex)

63+ return (DoBind fc n nfc tm', ex)

6464extractDoUnquotes d (DoBindP fc t t' alts)

6565 = fail "Pattern-matching binds cannot be quasiquoted"

66−extractDoUnquotes d (DoLet fc n v b)

66+extractDoUnquotes d (DoLet fc n nfc v b)

6767 = do (v', ex1) <- extractUnquotes d v

6868 (b', ex2) <- extractUnquotes d b

69− return (DoLet fc n v' b', ex1 ++ ex2)

69+ return (DoLet fc n nfc v' b', ex1 ++ ex2)

7070extractDoUnquotes d (DoLetP fc t t') = fail "Pattern-matching lets cannot be quasiquoted"

7171

7272

7373extractUnquotes :: Int -> PTerm -> Elab' aux (PTerm, [(Name, PTerm)])

74−extractUnquotes n (PLam fc name ty body)

74+extractUnquotes n (PLam fc name nfc ty body)

7575 = do (ty', ex1) <- extractUnquotes n ty

7676 (body', ex2) <- extractUnquotes n body

77− return (PLam fc name ty' body', ex1 ++ ex2)

78−extractUnquotes n (PPi plicity name ty body)

77+ return (PLam fc name nfc ty' body', ex1 ++ ex2)

78+extractUnquotes n (PPi plicity name fc ty body)

7979 = do (ty', ex1) <- extractUnquotes n ty

8080 (body', ex2) <- extractUnquotes n body

81− return (PPi plicity name ty' body', ex1 ++ ex2)

82−extractUnquotes n (PLet fc name ty val body)

81+ return (PPi plicity name fc ty' body', ex1 ++ ex2)

82+extractUnquotes n (PLet fc name nfc ty val body)

8383 = do (ty', ex1) <- extractUnquotes n ty

8484 (val', ex2) <- extractUnquotes n val

8585 (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)

8787extractUnquotes n (PTyped tm ty)

8888 = do (tm', ex1) <- extractUnquotes n tm

8989 (ty', ex2) <- extractUnquotes n ty

src/Idris/Error.hs+8−8

@@ -91,9 +91,9 @@ warnDisamb ist (PQuote _) = return ()

9191warnDisamb ist (PRef _ _) = return ()

9292warnDisamb ist (PInferRef _ _) = return ()

9393warnDisamb ist (PPatvar _ _) = return ()

94−warnDisamb ist (PLam _ _ 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

94+warnDisamb ist (PLam _ _ _ 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

9797warnDisamb ist (PTyped x t) = warnDisamb ist x >> warnDisamb ist t

9898warnDisamb ist (PApp _ t args) = warnDisamb ist t >>

9999 mapM_ (warnDisamb ist . getTm) args

@@ -111,17 +111,17 @@ warnDisamb ist (PPair _ _ x y) = warnDisamb ist x >> warnDisamb ist y

111111warnDisamb ist (PDPair _ _ x y z) = warnDisamb ist x >> warnDisamb ist y >> warnDisamb ist z

112112warnDisamb ist (PAlternative _ tms) = mapM_ (warnDisamb ist) tms

113113warnDisamb ist (PHidden tm) = warnDisamb ist tm

114−warnDisamb ist PType = return ()

114+warnDisamb ist (PType _) = return ()

115115warnDisamb ist (PUniverse _) = return ()

116116warnDisamb ist (PGoal _ x _ y) = warnDisamb ist x >> warnDisamb ist y

117−warnDisamb ist (PConstant _) = return ()

117+warnDisamb ist (PConstant _ _) = return ()

118118warnDisamb ist Placeholder = return ()

119119warnDisamb ist (PDoBlock steps) = mapM_ wStep steps

120120 where wStep (DoExp _ x) = warnDisamb ist x

121− wStep (DoBind _ _ x) = warnDisamb ist x

121+ wStep (DoBind _ _ _ x) = warnDisamb ist x

122122 wStep (DoBindP _ x y cs) = warnDisamb ist x >> warnDisamb ist y >>

123− mapM_ (\(x,y)-> warnDisamb ist x >> warnDisamb ist y) cs

124− wStep (DoLet _ _ x y) = warnDisamb ist x >> warnDisamb ist y

123+ mapM_ (\(x,y) -> warnDisamb ist x >> warnDisamb ist y) cs

124+ wStep (DoLet _ _ _ x y) = warnDisamb ist x >> warnDisamb ist y

125125 wStep (DoLetP _ x y) = warnDisamb ist x >> warnDisamb ist y

126126warnDisamb ist (PIdiom _ x) = warnDisamb ist x

127127warnDisamb ist (PReturn _) = return ()

src/Idris/IBC.hs+74−48

@@ -41,7 +41,7 @@ import Codec.Archive.Zip

4141import Util.Zlib (decompressEither)

4242

4343ibcVersion :: Word16

44−ibcVersion = 107

44+ibcVersion = 108

4545

4646data IBCFile = IBCFile { ver :: Word16,

4747 sourcefile :: FilePath,

@@ -1144,7 +1144,7 @@ instance (Binary t) => Binary (PDecl' t) where

11441144 put x1

11451145 put x2

11461146 put x3

1147− PTy x1 x2 x3 x4 x5 x6 x7

1147+ PTy x1 x2 x3 x4 x5 x6 x7 x8

11481148 -> do putWord8 1

11491149 put x1

11501150 put x2

@@ -1153,6 +1153,7 @@ instance (Binary t) => Binary (PDecl' t) where

11531153 put x5

11541154 put x6

11551155 put x7

1156+ put x8

11561157 PClauses x1 x2 x3 x4 -> do putWord8 2

11571158 put x1

11581159 put x2

@@ -1173,7 +1174,7 @@ instance (Binary t) => Binary (PDecl' t) where

11731174 PNamespace x1 x2 -> do putWord8 5

11741175 put x1

11751176 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 ->

11771178 do putWord8 6

11781179 put x1

11791180 put x2

@@ -1186,7 +1187,8 @@ instance (Binary t) => Binary (PDecl' t) where

11861187 put x9

11871188 put x10

11881189 put x11

1189− PClass x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11

1190+ put x12

1191+ PClass x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12

11901192 -> do putWord8 7

11911193 put x1

11921194 put x2

@@ -1199,7 +1201,8 @@ instance (Binary t) => Binary (PDecl' t) where

11991201 put x9

12001202 put x10

12011203 put x11

1202− PInstance x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 ->

1204+ put x12

1205+ PInstance x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 ->

12031206 do putWord8 8

12041207 put x1

12051208 put x2

@@ -1211,6 +1214,7 @@ instance (Binary t) => Binary (PDecl' t) where

12111214 put x8

12121215 put x9

12131216 put x10

1217+ put x11

12141218 PDSL x1 x2 -> do putWord8 9

12151219 put x1

12161220 put x2

@@ -1260,7 +1264,8 @@ instance (Binary t) => Binary (PDecl' t) where

12601264 x5 <- get

12611265 x6 <- get

12621266 x7 <- get

1263− return (PTy x1 x2 x3 x4 x5 x6 x7)

1267+ x8 <- get

1268+ return (PTy x1 x2 x3 x4 x5 x6 x7 x8)

12641269 2 -> do x1 <- get

12651270 x2 <- get

12661271 x3 <- get

@@ -1291,7 +1296,8 @@ instance (Binary t) => Binary (PDecl' t) where

12911296 x9 <- get

12921297 x10 <- get

12931298 x11 <- get

1294− return (PRecord x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11)

1299+ x12 <- get

1300+ return (PRecord x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12)

12951301 7 -> do x1 <- get

12961302 x2 <- get

12971303 x3 <- get

@@ -1303,7 +1309,8 @@ instance (Binary t) => Binary (PDecl' t) where

13031309 x9 <- get

13041310 x10 <- get

13051311 x11 <- get

1306− return (PClass x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11)

1312+ x12 <- get

1313+ return (PClass x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12)

13071314 8 -> do x1 <- get

13081315 x2 <- get

13091316 x3 <- get

@@ -1314,7 +1321,8 @@ instance (Binary t) => Binary (PDecl' t) where

13141321 x8 <- get

13151322 x9 <- get

13161323 x10 <- get

1317− return (PInstance x1 x2 x3 x4 x5 x6 x7 x8 x9 x10)

1324+ x11 <- get

1325+ return (PInstance x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11)

13181326 9 -> do x1 <- get

13191327 x2 <- get

13201328 return (PDSL x1 x2)

@@ -1457,23 +1465,27 @@ instance (Binary t) => Binary (PClause' t) where

14571465instance (Binary t) => Binary (PData' t) where

14581466 put x

14591467 = case x of

1460− PDatadecl x1 x2 x3 -> do putWord8 0

1461− put x1

1462− put x2

1463− put x3

1464− PLaterdecl x1 x2 -> do putWord8 1

1465− put x1

1466− put x2

1468+ PDatadecl x1 x2 x3 x4 -> do putWord8 0

1469+ put x1

1470+ put x2

1471+ put x3

1472+ put x4

1473+ PLaterdecl x1 x2 x3 -> do putWord8 1

1474+ put x1

1475+ put x2

1476+ put x3

14671477 get

14681478 = do i <- getWord8

14691479 case i of

14701480 0 -> do x1 <- get

14711481 x2 <- get

14721482 x3 <- get

1473− return (PDatadecl x1 x2 x3)

1483+ x4 <- get

1484+ return (PDatadecl x1 x2 x3 x4)

14741485 1 -> do x1 <- get

14751486 x2 <- get

1476− return (PLaterdecl x1 x2)

1487+ x3 <- get

1488+ return (PLaterdecl x1 x2 x3)

14771489 _ -> error "Corrupted binary data for PData'"

14781490

14791491instance Binary PunInfo where

@@ -1504,22 +1516,25 @@ instance Binary PTerm where

15041516 PPatvar x1 x2 -> do putWord8 3

15051517 put x1

15061518 put x2

1507− PLam x1 x2 x3 x4 -> 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

1519+ PLam x1 x2 x3 x4 x5 -> do putWord8 4

15181520 put x1

15191521 put x2

15201522 put x3

15211523 put x4

15221524 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

15231538 PTyped x1 x2 -> do putWord8 7

15241539 put x1

15251540 put x2

@@ -1565,14 +1580,16 @@ instance Binary PTerm where

15651580 put x2

15661581 PHidden x1 -> do putWord8 21

15671582 put x1

1568− PType -> putWord8 22

1583+ PType x1 -> do putWord8 22

1584+ put x1

15691585 PGoal x1 x2 x3 x4 -> do putWord8 23

15701586 put x1

15711587 put x2

15721588 put x3

15731589 put x4

1574− PConstant x1 -> do putWord8 24

1575− put x1

1590+ PConstant x1 x2 -> do putWord8 24

1591+ put x1

1592+ put x2

15761593 Placeholder -> putWord8 25

15771594 PDoBlock x1 -> do putWord8 26

15781595 put x1

@@ -1639,18 +1656,21 @@ instance Binary PTerm where

16391656 x2 <- get

16401657 x3 <- get

16411658 x4 <- get

1642− return (PLam x1 x2 x3 x4)

1659+ x5 <- get

1660+ return (PLam x1 x2 x3 x4 x5)

16431661 5 -> do x1 <- get

16441662 x2 <- get

16451663 x3 <- get

16461664 x4 <- get

1647− return (PPi x1 x2 x3 x4)

1665+ x5 <- get

1666+ return (PPi x1 x2 x3 x4 x5)

16481667 6 -> do x1 <- get

16491668 x2 <- get

16501669 x3 <- get

16511670 x4 <- get

16521671 x5 <- get

1653− return (PLet x1 x2 x3 x4 x5)

1672+ x6 <- get

1673+ return (PLet x1 x2 x3 x4 x5 x6)

16541674 7 -> do x1 <- get

16551675 x2 <- get

16561676 return (PTyped x1 x2)

@@ -1695,14 +1715,16 @@ instance Binary PTerm where

16951715 return (PAlternative x1 x2)

16961716 21 -> do x1 <- get

16971717 return (PHidden x1)

1698− 22 -> return PType

1718+ 22 -> do x1 <- get

1719+ return (PType x1)

16991720 23 -> do x1 <- get

17001721 x2 <- get

17011722 x3 <- get

17021723 x4 <- get

17031724 return (PGoal x1 x2 x3 x4)

17041725 24 -> do x1 <- get

1705− return (PConstant x1)

1726+ x2 <- get

1727+ return (PConstant x1 x2)

17061728 25 -> return Placeholder

17071729 26 -> do x1 <- get

17081730 return (PDoBlock x1)

@@ -1921,20 +1943,22 @@ instance (Binary t) => Binary (PDo' t) where

19211943 DoExp x1 x2 -> do putWord8 0

19221944 put x1

19231945 put x2

1924− DoBind x1 x2 x3 -> do putWord8 1

1925− put x1

1926− put x2

1927− put x3

1946+ DoBind x1 x2 x3 x4 -> do putWord8 1

1947+ put x1

1948+ put x2

1949+ put x3

1950+ put x4

19281951 DoBindP x1 x2 x3 x4 -> do putWord8 2

19291952 put x1

19301953 put x2

19311954 put x3

19321955 put x4

1933− DoLet x1 x2 x3 x4 -> do putWord8 3

1934− put x1

1935− put x2

1936− put x3

1937− put x4

1956+ DoLet x1 x2 x3 x4 x5 -> do putWord8 3

1957+ put x1

1958+ put x2

1959+ put x3

1960+ put x4

1961+ put x5

19381962 DoLetP x1 x2 x3 -> do putWord8 4

19391963 put x1

19401964 put x2

@@ -1948,7 +1972,8 @@ instance (Binary t) => Binary (PDo' t) where

19481972 1 -> do x1 <- get

19491973 x2 <- get

19501974 x3 <- get

1951− return (DoBind x1 x2 x3)

1975+ x4 <- get

1976+ return (DoBind x1 x2 x3 x4)

19521977 2 -> do x1 <- get

19531978 x2 <- get

19541979 x3 <- get

@@ -1958,7 +1983,8 @@ instance (Binary t) => Binary (PDo' t) where

19581983 x2 <- get

19591984 x3 <- get

19601985 x4 <- get

1961− return (DoLet x1 x2 x3 x4)

1986+ x5 <- get

1987+ return (DoLet x1 x2 x3 x4 x5)

19621988 4 -> do x1 <- get

19631989 x2 <- get

19641990 x3 <- get

src/Idris/IdeMode.hs+2

@@ -169,6 +169,8 @@ instance SExpable FC where

169169 toSExp ((SymbolAtom "filename", StringAtom f),

170170 (SymbolAtom "start", IntegerAtom (toInteger sl), IntegerAtom (toInteger sc)),

171171 (SymbolAtom "end", IntegerAtom (toInteger el), IntegerAtom (toInteger ec)))

172+ toSExp NoFC = toSExp ([] :: [String])

173+ toSExp (FileFC f) = toSExp [(SymbolAtom "filename", StringAtom f)]

172174

173175escape :: String -> String

174176escape = concatMap escapeChar

src/Idris/IdrisDoc.hs+10−10

@@ -291,9 +291,9 @@ extractPTermNames :: PTerm -- ^ Where to extract names from

291291extractPTermNames (PRef _ n) = [n]

292292extractPTermNames (PInferRef _ n) = [n]

293293extractPTermNames (PPatvar _ n) = [n]

294−extractPTermNames (PLam _ 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]

294+extractPTermNames (PLam _ 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]

297297extractPTermNames (PTyped p1 p2) = concatMap extract [p1, p2]

298298extractPTermNames (PApp _ p pas) = let names = concatMap extractPArg pas

299299 in (extract p) ++ names

@@ -338,13 +338,13 @@ extractPArg (PTacImplicit {pname=n, getScript=p1, getTm=p2})

338338

339339-- | Helper function for extractPTermNames

340340extractPDo :: PDo -> [Name]

341−extractPDo (DoExp _ p) = extract p

342−extractPDo (DoBind _ n p) = n : extract p

343−extractPDo (DoBindP _ p1 p2 ps) = let (ps1, ps2) = unzip ps

344− ps' = ps1 ++ ps2

345− in concatMap extract (p1 : p2 : ps')

346−extractPDo (DoLet _ n p1 p2) = n : concatMap extract [p1, p2]

347−extractPDo (DoLetP _ p1 p2) = concatMap extract [p1, p2]

341+extractPDo (DoExp _ p) = extract p

342+extractPDo (DoBind _ n _ p) = n : extract p

343+extractPDo (DoBindP _ p1 p2 ps) = let (ps1, ps2) = unzip ps

344+ ps' = ps1 ++ ps2

345+ in concatMap extract (p1 : p2 : ps')

346+extractPDo (DoLet _ n _ p1 p2) = n : concatMap extract [p1, p2]

347+extractPDo (DoLetP _ p1 p2) = concatMap extract [p1, p2]

348348

349349-- | Helper function for extractPTermNames

350350extractPTactic :: PTactic -> [Name]

src/Idris/Interactive.hs+6−6

@@ -197,9 +197,9 @@ doProofSearch fn updatefile rec l n hints (Just depth)

197197 runIO $ copyFile fb fn

198198 else iPrintResult newmv

199199 where dropCtxt 0 sc = sc

200− dropCtxt i (PPi _ _ _ sc) = dropCtxt (i - 1) sc

201− dropCtxt i (PLet _ _ _ _ sc) = dropCtxt (i - 1) sc

202− dropCtxt i (PLam _ _ _ sc) = dropCtxt (i - 1) sc

200+ dropCtxt i (PPi _ _ _ _ sc) = dropCtxt (i - 1) sc

201+ dropCtxt i (PLet _ _ _ _ _ sc) = dropCtxt (i - 1) sc

202+ dropCtxt i (PLam _ _ _ _ sc) = dropCtxt (i - 1) sc

203203 dropCtxt _ t = t

204204

205205 stripNS tm = mapPT dens tm where

@@ -304,11 +304,11 @@ makeLemma fn updatefile l n

304304 appArgs skip i (Bind _ (Pi _ _ _) sc) = appArgs skip (i - 1) sc

305305 appArgs skip i _ = ""

306306

307− stripMNBind skip (PPi b n@(UN c) ty sc)

307+ stripMNBind skip (PPi b n@(UN c) _ ty sc)

308308 | (thead c /= '_' && n `notElem` skip) ||

309309 take 4 (str c) == "__pi" -- keep in type, but not in app

310− = PPi b n ty (stripMNBind skip sc)

311− stripMNBind skip (PPi b _ ty sc) = stripMNBind skip sc

310+ = PPi b n NoFC ty (stripMNBind skip sc)

311+ stripMNBind skip (PPi b _ _ ty sc) = stripMNBind skip sc

312312 stripMNBind skip t = t

313313

314314 -- 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

3333pshow :: IState -> Err -> String

3434pshow ist err = displayDecorated (consoleDecorate ist) .

3535 renderPretty 1.0 80 .

36− fmap (fancifyAnnots ist) $ pprintErr ist err

36+ fmap (fancifyAnnots ist True) $ pprintErr ist err

3737

3838iWarn :: FC -> Doc OutputAnnotation -> Idris ()

3939iWarn fc err =

4040 do i <- getIState

4141 case idris_outputmode i of

4242 RawOutput h ->

43− do err' <- iRender . fmap (fancifyAnnots i) $

44− if fc_fname fc /= ""

45− then text (show fc) <> colon <//> err

46− else err

43+ do err' <- iRender . fmap (fancifyAnnots i True) $

44+ case fc of

45+ FC fn _ _ | fn /= "" -> text (show fc) <> colon <//> err

46+ _ -> err

4747 runIO . hPutStrLn h $ displayDecorated (consoleDecorate i) err'

4848 IdeMode n h ->

49− do err' <- iRender . fmap (fancifyAnnots i) $ err

49+ do err' <- iRender . fmap (fancifyAnnots i True) $ err

5050 let (str, spans) = displaySpans err'

5151 runIO . hPutStrLn h $

5252 convSExp "warning" (fc_fname fc, fc_start fc, fc_end fc, str, spans) n

@@ -97,7 +97,7 @@ iRenderOutput doc =

9797 RawOutput h -> do out <- iRender doc

9898 runIO $ putStrLn (displayDecorated (consoleDecorate i) out)

9999 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

101101 let out = [toSExp str, toSExp spans]

102102 runIO . hPutStrLn h $ convSExp "write-decorated" out n

103103

@@ -112,7 +112,7 @@ ideModeReturnWithStatus status n h out = do

112112 ist <- getIState

113113 (str, spans) <- fmap displaySpans .

114114 iRender .

115− fmap (fancifyAnnots ist) $

115+ fmap (fancifyAnnots ist True) $

116116 out

117117 let good = [SymbolAtom status, toSExp str, toSExp spans]

118118 runIO . hPutStrLn h $ convSExp "return" good n

@@ -168,7 +168,7 @@ iputGoal g = do i <- getIState

168168 case idris_outputmode i of

169169 RawOutput h -> runIO $ hPutStrLn h (displayDecorated (consoleDecorate i) g)

170170 IdeMode n h ->

171− let (str, spans) = displaySpans . fmap (fancifyAnnots i) $ g

171+ let (str, spans) = displaySpans . fmap (fancifyAnnots i True) $ g

172172 goal = [toSExp str, toSExp spans]

173173 in runIO . hPutStrLn h $ convSExp "write-goal" goal n

174174

@@ -194,6 +194,24 @@ prettyDocumentedIst ist (name, ty, docs) =

194194 where ppTm = pprintDelab ist

195195 norm = normaliseAll (tt_ctxt ist) []

196196

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+

197215

198216renderExternal :: OutputFmt -> Int -> Doc OutputAnnotation -> Idris String

199217renderExternal fmt width doc

@@ -203,7 +221,7 @@ renderExternal fmt width doc

203221 return . wrap fmt .

204222 displayDecorated (decorate fmt) .

205223 renderPretty 1.0 width .

206− fmap (fancifyAnnots ist) $

224+ fmap (fancifyAnnots ist True) $

207225 doc

208226 where

209227 decorate _ (AnnFC _) = id

src/Idris/ParseData.hs+51−49

@@ -53,29 +53,29 @@ record syn = do (doc, paramDocs, acc, opts) <- try (do

5353 co <- recordI

5454 return (doc', paramDocs', acc, opts ++ co))

5555 fc <- getFC

56− tyn_in <- fnName

56+ (tyn_in, nfc) <- fnName

5757 let tyn = expandNS syn tyn_in

5858 let rsyn = syn { syn_namespace = show (nsroot tyn) :

59− syn_namespace syn }

59+ syn_namespace syn }

6060 params <- manyTill (recordParameter rsyn) (reserved "where")

61− (fields, cname, cdoc) <- indentedBlockS $ agdaStyleBody rsyn tyn

61+ (fields, cname, cdoc) <- indentedBlockS $ recordBody rsyn tyn

6262 case cname of

63− Just cn' -> accData acc tyn [cn']

63+ Just cn' -> accData acc tyn [fst cn']

6464 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

6666 <?> "record type declaration"

67− where

67+ where

6868 getRecNames :: SyntaxInfo -> PTerm -> [Name]

69− getRecNames syn (PPi _ n _ sc) = [expandNS syn n, expandNS syn (mkType n)]

70− ++ getRecNames syn sc

69+ getRecNames syn (PPi _ n _ _ sc) = [expandNS syn n, expandNS syn (mkType n)]

70+ ++ getRecNames syn sc

7171 getRecNames _ _ = []

7272

7373 toFreeze :: Maybe Accessibility -> Maybe Accessibility

7474 toFreeze (Just Frozen) = Just Hidden

7575 toFreeze x = x

7676

77− agdaStyleBody :: SyntaxInfo -> Name -> IdrisParser ([((Maybe Name), Plicity, PTerm, Maybe (Docstring (Either Err PTerm)))], Maybe Name, Docstring (Either Err PTerm))

78− agdaStyleBody syn tyn = do

77+ recordBody :: SyntaxInfo -> Name -> IdrisParser ([((Maybe (Name, FC)), Plicity, PTerm, Maybe (Docstring (Either Err PTerm)))], Maybe (Name, FC), Docstring (Either Err PTerm))

78+ recordBody syn tyn = do

7979 ist <- get

8080 fc <- getFC

8181

@@ -87,14 +87,14 @@ record syn = do (doc, paramDocs, acc, opts) <- try (do

8787 let constructorDoc' = annotate syn ist constructorDoc

8888

8989 fields <- many . indented $ field syn

90−

90+

9191 return (fields, constructorName, constructorDoc')

9292 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)))

9494 field syn = do doc <- optional docComment

9595 c <- optional $ lchar '{'

96− n <- (do n <- fnName

97− return $ Just (expandNS syn n))

96+ n <- (do (n, nfc) <- fnName

97+ return $ Just (expandNS syn n, nfc))

9898 <|> (do symbol "_"

9999 return Nothing)

100100 lchar ':'

@@ -106,8 +106,9 @@ record syn = do (doc, paramDocs, acc, opts) <- try (do

106106 Nothing -> Nothing

107107 return (n, p, t, doc')

108108

109− constructor :: IdrisParser Name

110− constructor = reserved "constructor" *> fnName

109+ constructor :: IdrisParser (Name, FC)

110+ constructor = (reserved "constructor") *> fnName

111+

111112

112113 endPlicity :: Maybe Char -> IdrisParser Plicity

113114 endPlicity (Just _) = do lchar '}'

@@ -117,26 +118,27 @@ record syn = do (doc, paramDocs, acc, opts) <- try (do

117118 annotate :: SyntaxInfo -> IState -> Docstring () -> Docstring (Either Err PTerm)

118119 annotate syn ist = annotCode $ tryFullExpr syn ist

119120

120−recordParameter :: SyntaxInfo -> IdrisParser (Name, Plicity, PTerm)

121+recordParameter :: SyntaxInfo -> IdrisParser (Name, FC, Plicity, PTerm)

121122recordParameter syn =

122123 (do lchar '('

123− (n, pt) <- (namedTy syn <|> onlyName syn)

124+ (n, nfc, pt) <- (namedTy syn <|> onlyName syn)

124125 lchar ')'

125− return (n, expl, pt))

126+ return (n, nfc, expl, pt))

126127 <|>

127− (do (n, pt) <- onlyName syn

128− return (n, expl, pt))

128+ (do (n, nfc, pt) <- onlyName syn

129+ return (n, nfc, expl, pt))

129130 where

130− namedTy :: SyntaxInfo -> IdrisParser (Name, PTerm)

131+ namedTy :: SyntaxInfo -> IdrisParser (Name, FC, PTerm)

131132 namedTy syn =

132− do n <- fnName

133+ do (n, nfc) <- fnName

133134 lchar ':'

134135 ty <- typeExpr (allowImp syn)

135− return (expandNS syn n, ty)

136− onlyName :: SyntaxInfo -> IdrisParser (Name, PTerm)

136+ return (expandNS syn n, nfc, ty)

137+ onlyName :: SyntaxInfo -> IdrisParser (Name, FC, PTerm)

137138 onlyName syn =

138− do n <- fnName

139− return (expandNS syn n, PType)

139+ do (n, nfc) <- fnName

140+ fc <- getFC

141+ return (expandNS syn n, nfc, PType fc)

140142

141143{- | Parses data declaration type (normal or codata)

142144DataI ::= 'data' | 'codata';

@@ -189,20 +191,20 @@ data_ syn = do (doc, argDocs, acc, dataOpts) <- try (do

189191 | (n, d) <- argDocs ]

190192 return (doc', argDocs', acc, dataOpts))

191193 fc <- getFC

192− tyn_in <- fnName

194+ (tyn_in, nfc) <- fnName

193195 (do try (lchar ':')

194196 popIndent

195197 ty <- typeExpr (allowImp syn)

196198 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

198200 reserved "where"

199201 cons <- indentedBlock (constructor syn)

200− accData acc tyn (map (\ (_, _, n, _, _, _) -> n) cons)

201− return $ PData doc argDocs syn fc dataOpts (PDatadecl tyn ty cons))) <|> (do

202− args <- many name

203− let ty = bindArgs (map (const PType) args) PType

202+ accData acc tyn (map (\ (_, _, n, _, _, _, _) -> n) cons)

203+ return $ PData doc argDocs syn fc dataOpts (PDatadecl tyn nfc ty cons))) <|> (do

204+ args <- many (fst <$> name)

205+ let ty = bindArgs (map (const (PType fc)) args) (PType fc)

204206 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

206208 try (lchar '=') <|> do reserved "where"

207209 let kw = (if DefaultEliminator `elem` dataOpts then "%elim" else "") ++ (if Codata `elem` dataOpts then "co" else "") ++ "data "

208210 let n = show tyn_in ++ " "

@@ -217,18 +219,18 @@ data_ syn = do (doc, argDocs, acc, dataOpts) <- try (do

217219 cons <- sepBy1 (simpleConstructor syn) (reservedOp "|")

218220 terminator

219221 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) ->

221223 do let cty = bindArgs cargs conty

222− return (doc, argDocs, x, cty, cfc, fs)) cons

223− accData acc tyn (map (\ (_, _, n, _, _, _) -> n) cons')

224− return $ PData doc argDocs syn fc dataOpts (PDatadecl tyn ty cons')))

224+ return (doc, argDocs, x, xfc, cty, cfc, fs)) cons

225+ accData acc tyn (map (\ (_, _, n, _, _, _, _) -> n) cons')

226+ return $ PData doc argDocs syn fc dataOpts (PDatadecl tyn nfc ty cons')))

225227 <?> "data type declaration"

226228 where

227229 mkPApp :: FC -> PTerm -> [PTerm] -> PTerm

228230 mkPApp fc t [] = t

229231 mkPApp fc t xs = PApp fc t (map pexp xs)

230232 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

232234 combineDataOpts :: DataOpts -> DataOpts

233235 combineDataOpts opts = if Codata `elem` opts

234236 then delete DefaultEliminator opts

@@ -238,36 +240,36 @@ data_ syn = do (doc, argDocs, acc, dataOpts) <- try (do

238240{- | Parses a type constructor declaration

239241 Constructor ::= DocComment? FnName TypeSig;

240242-}

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])

242244constructor syn

243245 = do (doc, argDocs) <- option noDocs docComment

244− cn_in <- fnName; fc <- getFC

246+ (cn_in, nfc) <- fnName; fc <- getFC

245247 let cn = expandNS syn cn_in

246248 lchar ':'

247249 fs <- option [] (do lchar '%'; reserved "erase"

248− sepBy1 name (lchar ','))

250+ sepBy1 (fst <$> name) (lchar ','))

249251 ty <- typeExpr (allowImp syn)

250252 ist <- get

251253 let doc' = annotCode (tryFullExpr syn ist) doc

252254 argDocs' = [ (n, annotCode (tryFullExpr syn ist) d)

253255 | (n, d) <- argDocs ]

254− return (doc', argDocs', cn, ty, fc, fs)

256+ return (doc', argDocs', cn, nfc, ty, fc, fs)

255257 <?> "constructor"

256258

257259{- | Parses a constructor for simple discriminated union data types

258260 SimpleConstructor ::= FnName SimpleExpr* DocComment?

259261-}

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])

261263simpleConstructor syn

262264 = do (doc, _) <- option noDocs (try docComment)

263265 ist <- get

264266 let doc' = annotCode (tryFullExpr syn ist) doc

265− cn_in <- fnName

267+ (cn_in, nfc) <- fnName

266268 let cn = expandNS syn cn_in

267269 fc <- getFC

268270 args <- many (do notEndApp

269271 simpleExpr syn)

270− return (doc', [], cn, args, fc, [])

272+ return (doc', [], cn, nfc, args, fc, [])

271273 <?> "constructor"

272274

273275{- | Parses a dsl block declaration

@@ -275,7 +277,7 @@ DSL ::= 'dsl' FnName OpenBlock Overload'+ CloseBlock;

275277 -}

276278dsl :: SyntaxInfo -> IdrisParser PDecl

277279dsl syn = do reserved "dsl"

278− n <- fnName

280+ n <- fst <$> fnName

279281 bs <- indentedBlock (overload syn)

280282 let dsl = mkDSL bs (dsl_info syn)

281283 checkDSL dsl

@@ -312,8 +314,8 @@ OverloadIdentifier ::= 'let' | Identifier;

312314Overload ::= OverloadIdentifier '=' Expr;

313315-}

314316overload :: SyntaxInfo -> IdrisParser (String, PTerm)

315−overload syn = do o <- identifier <|> do reserved "let"

316− return "let"

317+overload syn = do o <- (fst <$> identifier) <|> do reserved "let"

318+ return "let"

317319 if o `notElem` overloadable

318320 then fail $ show o ++ " is not an overloading"

319321 else do

src/Idris/ParseExpr.hs+122−112

@@ -142,7 +142,7 @@ extension syn ns rules =

142142 return $ Just (n, SynTm tm)

143143 extensionSymbol (SimpleExpr n) = do tm <- simpleExpr syn

144144 return $ Just (n, SynTm tm)

145− extensionSymbol (Binding n) = do b <- name

145+ extensionSymbol (Binding n) = do b <- fst <$> name

146146 return $ Just (n, SynBind b)

147147 extensionSymbol (Symbol s) = do symbol s

148148 return Nothing

@@ -164,13 +164,13 @@ extension syn ns rules =

164164 update ns (PRef fc n) = case lookup n ns of

165165 Just (SynTm t) -> t

166166 _ -> PRef fc n

167− update ns (PLam fc n ty sc)

168− = PLam fc (updateB ns n) (update ns ty) (update (dropn n ns) sc)

169− update ns (PPi p n ty sc)

170− = PPi (updTacImp ns p) (updateB ns n)

167+ update ns (PLam fc n nfc ty sc)

168+ = PLam fc (updateB ns n) nfc (update ns ty) (update (dropn n ns) sc)

169+ update ns (PPi p n fc ty sc)

170+ = PPi (updTacImp ns p) (updateB ns n) fc

171171 (update ns ty) (update (dropn n ns) sc)

172− update ns (PLet fc n ty val sc)

173− = PLet fc (updateB ns n) (update ns ty)

172+ update ns (PLet fc n nfc ty val sc)

173+ = PLet fc (updateB ns n) nfc (update ns ty)

174174 (update ns val) (update (dropn n ns) sc)

175175 update ns (PApp fc t args)

176176 = PApp fc (update ns t) (map (fmap (update ns)) args)

@@ -188,9 +188,9 @@ extension syn ns rules =

188188 update ns (PDoBlock ds) = PDoBlock $ upd ns ds

189189 where upd :: [(Name, SynMatch)] -> [PDo] -> [PDo]

190190 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

192− upd ns (DoLet fc n ty t : ds) = DoLet fc n (update ns ty) (update ns t)

193− : 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 nfc ty t : ds) = DoLet fc n nfc (update ns ty) (update ns t)

193+ : upd (dropn n ns) ds

194194 upd ns (DoBindP fc i t ts : ds)

195195 = DoBindP fc (update ns i) (update ns t)

196196 (map (\(l,r) -> (update ns l, update ns r)) ts)

@@ -324,29 +324,29 @@ SimpleExpr ::=

324324simpleExpr :: SyntaxInfo -> IdrisParser PTerm

325325simpleExpr syn =

326326 try (simpleExternalExpr syn)

327− <|> do x <- try (lchar '?' *> name); return (PMetavar x)

327+ <|> do x <- try (lchar '?' *> (fst <$> name)); return (PMetavar x)

328328 <|> 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))

330330 <|> proofExpr syn

331331 <|> tacticsExpr syn

332332 <|> try (do reserved "Type"; symbol "*"; return $ PUniverse AllTypes)

333333 <|> do reserved "AnyType"; return $ PUniverse AllTypes

334− <|> do reserved "Type"; return PType

334+ <|> PType <$> reservedFC "Type"

335335 <|> do reserved "UniqueType"; return $ PUniverse UniqueType

336336 <|> do reserved "NullType"; return $ PUniverse NullType

337− <|> do c <- constant

337+ <|> do (c, cfc) <- constant

338338 fc <- getFC

339− return (modifyConst syn fc (PConstant c))

340− <|> do symbol "'"; fc <- getFC; str <- name

339+ return (modifyConst syn fc (PConstant cfc c))

340+ <|> do symbol "'"; fc <- getFC; str <- fst <$> name

341341 return (PApp fc (PRef fc (sUN "Symbol_"))

342− [pexp (PConstant (Str (show str)))])

343− <|> do fc <- getFC

344− x <- fnName

345− if inPattern syn

342+ [pexp (PConstant NoFC (Str (show str)))])

343+ <|> do (x, fc) <- fnName

344+ if inPattern syn

346345 then option (PRef fc x)

347346 (do reservedOp "@"

348347 s <- simpleExpr syn

349− return (PAs fc x s))

348+ fcIn <- getFC

349+ return (PAs fcIn x s))

350350 else return (PRef fc x)

351351 <|> idiom syn

352352 <|> listExpr syn

@@ -368,8 +368,9 @@ Bracketed ::= '(' Bracketed'

368368@

369369 -}

370370bracketed :: SyntaxInfo -> IdrisParser PTerm

371−bracketed syn = do lchar '(' <?> "parenthesized expression"

372− bracketed' syn

371+bracketed syn = do fc <- getFC

372+ lchar '(' <?> "parenthesized expression"

373+ bracketed' fc syn

373374{- |Parses the rest of an expression in braces

374375@

375376Bracketed' ::=

@@ -383,12 +384,12 @@ Bracketed' ::=

383384 ;

384385@

385386-}

386−bracketed' :: SyntaxInfo -> IdrisParser PTerm

387−bracketed' syn =

388− do lchar ')'

389− fc <- getFC

390− return $ PTrue fc TypeOrTerm

391− <|> try (do ln <- name; lchar ':';

387+bracketed' :: FC -> SyntaxInfo -> IdrisParser PTerm

388+bracketed' open syn =

389+ do (FC f start (l, c)) <- getFC

390+ lchar ')'

391+ return $ PTrue (spanFC open (FC f start (l, c+1))) TypeOrTerm

392+ <|> try (do ln <- fst <$> name; lchar ':';

392393 lty <- expr syn

393394 reservedOp "**"

394395 fc <- getFC

@@ -399,7 +400,7 @@ bracketed' syn =

399400 -- No prefix operators! (bit of a hack here...)

400401 if (o == "-" || o == "!")

401402 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

403404 (PApp fc (PRef fc (sUN o)) [pexp (PRef fc (sMN 1000 "ARG")),

404405 pexp e]))

405406 <|> try (do l <- simpleExpr syn

@@ -409,7 +410,7 @@ bracketed' syn =

409410 fc0 <- getFC

410411 case op of

411412 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

413414 (PApp fc0 (PRef fc0 (sUN o)) [pexp l,

414415 pexp (PRef fc0 (sMN 1000 "ARG"))]))

415416 <|> do l <- expr syn

@@ -441,19 +442,19 @@ bracketedExpr syn e =

441442-- name suggests, rather than Int

442443{-| Finds optimal type for integer constant -}

443444modifyConst :: SyntaxInfo -> FC -> PTerm -> PTerm

444−modifyConst syn fc (PConstant (BI x))

445+modifyConst syn fc (PConstant inFC (BI x))

445446 | not (inPattern syn)

446447 = 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)))]

448449 : consts)

449450 | otherwise = PAlternative False consts

450451 where

451− consts = [ PConstant (BI x)

452− , PConstant (I (fromInteger x))

453− , PConstant (B8 (fromInteger x))

454− , PConstant (B16 (fromInteger x))

455− , PConstant (B32 (fromInteger x))

456− , PConstant (B64 (fromInteger x))

452+ consts = [ PConstant inFC (BI x)

453+ , PConstant inFC (I (fromInteger x))

454+ , PConstant inFC (B8 (fromInteger x))

455+ , PConstant inFC (B16 (fromInteger x))

456+ , PConstant inFC (B32 (fromInteger x))

457+ , PConstant inFC (B64 (fromInteger x))

457458 ]

458459modifyConst syn fc x = x

459460

@@ -518,7 +519,7 @@ Disamb ::=

518519-}

519520disamb :: SyntaxInfo -> IdrisParser PTerm

520521disamb syn = do reserved "with";

521− ns <- sepBy1 name (lchar ',')

522+ ns <- sepBy1 (fst <$> name) (lchar ',')

522523 tm <- expr' syn

523524 return (PDisamb (map tons ns) tm)

524525 <?> "unification log expression"

@@ -553,8 +554,8 @@ app :: SyntaxInfo -> IdrisParser PTerm

553554app syn = do f <- simpleExpr syn

554555 (do try $ reservedOp "<=="

555556 fc <- getFC

556− ff <- fnName

557− return (PLet fc (sMN 0 "match")

557+ ff <- fst <$> fnName

558+ return (PLet fc (sMN 0 "match") NoFC

558559 f

559560 (PMatchApp fc ff)

560561 (PRef fc (sMN 0 "match")))

@@ -592,7 +593,7 @@ ImplicitArg ::=

592593-}

593594implicitArg :: SyntaxInfo -> IdrisParser PArg

594595implicitArg syn = do lchar '{'

595− n <- name

596+ n <- fst <$> name

596597 fc <- getFC

597598 v <- option (PRef fc n) (do lchar '='

598599 expr syn)

@@ -649,7 +650,7 @@ unquote syn = do guard (syn_in_quasiquote syn > 0)

649650-}

650651namequote :: SyntaxInfo -> IdrisParser PTerm

651652namequote syn = do symbol "`{"

652− n <- fnName

653+ n <- fst <$> fnName

653654 symbol "}"

654655 return $ PQuoteName n

655656 <?> "quoted name"

@@ -684,13 +685,13 @@ recordType syn =

684685 Left fields ->

685686 case rec of

686687 Nothing ->

687− return (PLam fc (sMN 0 "fldx") Placeholder

688+ return (PLam fc (sMN 0 "fldx") NoFC Placeholder

688689 (applyAll fc fields (PRef fc (sMN 0 "fldx"))))

689690 Just v -> return (applyAll fc fields v)

690691 Right fields ->

691692 case rec of

692693 Nothing ->

693− return (PLam fc (sMN 0 "fldx") Placeholder

694+ return (PLam fc (sMN 0 "fldx") NoFC Placeholder

694695 (getAll fc (reverse fields)

695696 (PRef fc (sMN 0 "fldx"))))

696697 Just v -> return (getAll fc (reverse fields) v)

@@ -704,7 +705,7 @@ recordType syn =

704705 <?> "field setter"

705706

706707 fieldGet :: IdrisParser [Name]

707− fieldGet = sepBy1 fnName (symbol "->")

708+ fieldGet = sepBy1 (fst <$> fnName) (symbol "->")

708709

709710 fieldGetOrSet :: IdrisParser (Either [([Name], PTerm)] [Name])

710711 fieldGetOrSet = try (do fs <- sepBy1 fieldSet (lchar ',')

@@ -787,7 +788,7 @@ lambda syn = do lchar '\\' <?> "lambda expression"

787788 where pmList :: [(Int, (FC, PTerm))] -> PTerm -> PTerm

788789 pmList [] sc = sc

789790 pmList ((i, (fc, x)) : xs) sc

790− = PLam fc (sMN i "lamp") Placeholder

791+ = PLam fc (sMN i "lamp") NoFC Placeholder

791792 (PCase fc (PRef fc (sMN i "lamp"))

792793 [(x, pmList xs sc)])

793794 lambdaTail :: IdrisParser PTerm

@@ -829,12 +830,12 @@ let_ syn = try (do reserved "let"

829830 return (buildLets ls sc))

830831 <?> "let binding"

831832 where buildLets [] sc = sc

832− buildLets ((fc,PRef _ n,ty,v,[]):ls) sc

833− = PLet fc n ty v (buildLets ls sc)

834− buildLets ((fc,pat,ty,v,alts):ls) sc

833+ buildLets ((fc, PRef nfc n, ty, v, []) : ls) sc

834+ = PLet fc n nfc ty v (buildLets ls sc)

835+ buildLets ((fc, pat, ty, v, alts) : ls) sc

835836 = PCase fc v ((pat, buildLets ls sc) : alts)

836837

837−let_binding syn = do fc <- getFC;

838+let_binding syn = do fc <- getFC;

838839 pat <- expr' (syn { inPattern = True })

839840 ty <- option Placeholder (do lchar ':'; expr' syn)

840841 lchar '='

@@ -870,7 +871,7 @@ QuoteGoal ::=

870871@

871872 -}

872873quoteGoal :: SyntaxInfo -> IdrisParser PTerm

873−quoteGoal syn = do reserved "quoteGoal"; n <- name;

874+quoteGoal syn = do reserved "quoteGoal"; n <- fst <$> name;

874875 reserved "by"

875876 r <- expr syn

876877 reserved "in"

@@ -942,7 +943,7 @@ normalImplicit opts st syn = do

942943 return (bindList (PPi im) xt

943944 (bindList (PPi cl) cs sc))

944945

945−implicitPi opts st syn =

946+implicitPi opts st syn =

946947 autoImplicit opts st syn

947948 <|> defaultImplicit opts st syn

948949 <|> normalImplicit opts st syn

@@ -951,7 +952,7 @@ unboundPi opts st syn = do

951952 x <- opExpr syn

952953 (do binder <- bindsymbol opts st syn

953954 sc <- expr syn

954− return (PPi binder (sUN "__pi_arg") x sc))

955+ return (PPi binder (sUN "__pi_arg") NoFC x sc))

955956 <|> return x

956957

957958pi :: SyntaxInfo -> IdrisParser PTerm

@@ -983,11 +984,11 @@ ConstraintList ::=

983984 ;

984985@

985986-}

986−constraintList :: SyntaxInfo -> IdrisParser [(Name, PTerm)]

987+constraintList :: SyntaxInfo -> IdrisParser [(Name, FC, PTerm)]

987988constraintList syn = try (constraintList1 syn)

988989 <|> return []

989990

990−constraintList1 :: SyntaxInfo -> IdrisParser [(Name, PTerm)]

991+constraintList1 :: SyntaxInfo -> IdrisParser [(Name, FC, PTerm)]

991992constraintList1 syn = try (do lchar '('

992993 tys <- sepBy1 nexpr (lchar ',')

993994 lchar ')'

@@ -995,13 +996,13 @@ constraintList1 syn = try (do lchar '('

995996 return tys)

996997 <|> try (do t <- opExpr (disallowImp syn)

997998 reservedOp "=>"

998− return [(defname, t)])

999+ return [(defname, NoFC, t)])

9991000 <?> "type constraint list"

1000− where nexpr = try (do n <- name; lchar ':'

1001+ where nexpr = try (do (n, fc) <- name; lchar ':'

10011002 e <- expr syn

1002− return (n, e))

1003+ return (n, fc, e))

10031004 <|> do e <- expr syn

1004− return (defname, e)

1005+ return (defname, NoFC, e)

10051006 defname = sMN 0 "constrarg"

10061007

10071008{- | Parses a type declaration list

@@ -1019,16 +1020,16 @@ FunctionSignatureList ::=

10191020 ;

10201021@

10211022-}

1022−typeDeclList :: SyntaxInfo -> IdrisParser [(Name, PTerm)]

1023−typeDeclList syn = try (sepBy1 (do x <- fnName

1023+typeDeclList :: SyntaxInfo -> IdrisParser [(Name, FC, PTerm)]

1024+typeDeclList syn = try (sepBy1 (do (x, xfc) <- fnName

10241025 lchar ':'

10251026 t <- typeExpr (disallowImp syn)

1026− return (x,t))

1027+ return (x, xfc, t))

10271028 (lchar ','))

10281029 <|> do ns <- sepBy1 name (lchar ',')

10291030 lchar ':'

10301031 t <- typeExpr (disallowImp syn)

1031− return (map (\x -> (x, t)) ns)

1032+ return (map (\(x, xfc) -> (x, xfc, t)) ns)

10321033 <?> "type declaration list"

10331034

10341035{- | Parses a type declaration list with optional parameters

@@ -1043,17 +1044,17 @@ TypeOptDeclList ::=

10431044NameOrPlaceHolder ::= Name | '_';

10441045@

10451046-}

1046−tyOptDeclList :: SyntaxInfo -> IdrisParser [(Name, PTerm)]

1047−tyOptDeclList syn = sepBy1 (do x <- nameOrPlaceholder

1047+tyOptDeclList :: SyntaxInfo -> IdrisParser [(Name, FC, PTerm)]

1048+tyOptDeclList syn = sepBy1 (do (x, fc) <- nameOrPlaceholder

10481049 t <- option Placeholder (do lchar ':'

10491050 expr syn)

1050− return (x,t))

1051+ return (x, fc, t))

10511052 (lchar ',')

10521053 <?> "type declaration list"

1053− where nameOrPlaceholder :: IdrisParser Name

1054+ where nameOrPlaceholder :: IdrisParser (Name, FC)

10541055 nameOrPlaceholder = fnName

10551056 <|> do symbol "_"

1056− return (sMN 0 "underscore")

1057+ return (sMN 0 "underscore", NoFC)

10571058 <?> "name or placeholder"

10581059

10591060{- | Parses a list literal expression e.g. [1,2,3] or a comprehension [ (x, y) | x <- xs , y <- ys ]

@@ -1078,23 +1079,28 @@ ExprList ::=

10781079@

10791080 -}

10801081listExpr :: SyntaxInfo -> IdrisParser PTerm

1081−listExpr syn = do lchar '['; fc <- getFC;

1082− try ((lchar ']' <?> "end of list expression") *> return (mkList fc [])) <|> (do

1083− x <- expr syn <?> "expression"

1084− (do try (lchar '|') <?> "list comprehension"

1085− qs <- sepBy1 (do_ syn) (lchar ',')

1086− lchar ']'

1087− return (PDoBlock (map addGuard qs ++

1088− [DoExp fc (PApp fc (PRef fc (sUN "return"))

1089− [pexp x])]))) <|> (do

1090− xs <- many ((lchar ',' <?> "list element") *> expr syn)

1091− lchar ']' <?> "end of list expression"

1092− return (mkList fc (x:xs))))

1082+listExpr syn = do (FC f (l, c) _) <- getFC

1083+ lchar '['; fc <- getFC;

1084+ (try . token $ do (char ']' <?> "end of list expression")

1085+ (FC _ _ (l', c')) <- getFC

1086+ return (mkNil (FC f (l, c) (l', c'))))

1087+ <|> (do x <- expr syn <?> "expression"

1088+ (do try (lchar '|') <?> "list comprehension"

1089+ qs <- sepBy1 (do_ syn) (lchar ',')

1090+ lchar ']'

1091+ return (PDoBlock (map addGuard qs ++

1092+ [DoExp fc (PApp fc (PRef fc (sUN "return"))

1093+ [pexp x])]))) <|>

1094+ (do xs <- many ((lchar ',' <?> "list element") *> expr syn)

1095+ lchar ']' <?> "end of list expression"

1096+ return (mkList fc (x:xs))))

10931097 <?> "list expression"

10941098 where

1099+ mkNil :: FC -> PTerm

1100+ mkNil fc = PRef fc (sUN "Nil")

10951101 mkList :: FC -> [PTerm] -> PTerm

1096− mkList fc [] = PRef fc (sUN "Nil")

1097− mkList fc (x : xs) = PApp fc (PRef fc (sUN "::")) [pexp x, pexp (mkList fc xs)]

1102+ mkList fc [] = PRef NoFC (sUN "Nil")

1103+ mkList fc (x : xs) = PApp fc (PRef NoFC (sUN "::")) [pexp x, pexp (mkList fc xs)]

10981104 addGuard :: PDo -> PDo

10991105 addGuard (DoExp fc e) = DoExp fc (PApp fc (PRef fc (sUN "guard"))

11001106 [pexp e])

@@ -1132,27 +1138,27 @@ Do ::=

11321138do_ :: SyntaxInfo -> IdrisParser PDo

11331139do_ syn

11341140 = try (do reserved "let"

1135− i <- name

1141+ (i, ifc) <- name

11361142 ty <- option Placeholder (do lchar ':'

11371143 expr' syn)

11381144 reservedOp "="

11391145 fc <- getFC

11401146 e <- expr syn

1141− return (DoLet fc i ty e))

1147+ return (DoLet fc i ifc ty e))

11421148 <|> try (do reserved "let"

11431149 i <- expr' syn

11441150 reservedOp "="

11451151 fc <- getFC

11461152 sc <- expr syn

11471153 return (DoLetP fc i sc))

1148− <|> try (do i <- name

1154+ <|> try (do (i, ifc) <- name

11491155 symbol "<-"

11501156 fc <- getFC

11511157 e <- expr syn;

1152− option (DoBind fc i e)

1158+ option (DoBind fc i ifc e)

11531159 (do lchar '|'

11541160 ts <- sepBy1 (do_alt syn) (lchar '|')

1155− return (DoBindP fc (PRef fc i) e ts)))

1161+ return (DoBindP fc (PRef ifc i) e ts)))

11561162 <|> try (do i <- expr' syn

11571163 symbol "<-"

11581164 fc <- getFC

@@ -1215,14 +1221,12 @@ Constant ::=

12151221-}

12161222

12171223constants :: [(String, Idris.Core.TT.Const)]

1218−constants =

1224+constants =

12191225 [ ("Integer", AType (ATInt ITBig))

12201226 , ("Int", AType (ATInt ITNative))

12211227 , ("Char", AType (ATInt ITChar))

12221228 , ("Double", AType ATFloat)

12231229 , ("String", StrType)

1224−-- , ("Ptr", PtrType)

1225−-- , ("ManagedPtr", ManagedPtrType)

12261230 , ("prim__WorldType", WorldType)

12271231 , ("prim__TheWorld", TheWorld)

12281232 , ("Bits8", AType (ATInt (ITFixed IT8)))

@@ -1230,14 +1234,17 @@ constants =

12301234 , ("Bits32", AType (ATInt (ITFixed IT32)))

12311235 , ("Bits64", AType (ATInt (ITFixed IT64)))

12321236 ]

1233−

1234−constant :: IdrisParser Idris.Core.TT.Const

1235−constant = choice [ do reserved name; return ty | (name, ty) <- constants ]

1236− <|> do f <- try float; return $ Fl f

1237− <|> do i <- natural; return $ BI i

1238− <|> do s <- verbatimStringLiteral; return $ Str s

1239− <|> do s <- stringLiteral; return $ Str s

1240− <|> do c <- try charLiteral; return $ Ch c --Currently ambigous with symbols

1237+

1238+-- | Parse a constant and its source span

1239+constant :: IdrisParser (Idris.Core.TT.Const, FC)

1240+constant = choice [ do fc <- reservedFC name; return (ty, fc)

1241+ | (name, ty) <- constants

1242+ ]

1243+ <|> do (f, fc) <- try float; return (Fl f, fc)

1244+ <|> do (i, fc) <- natural; return (BI i, fc)

1245+ <|> do (s, fc) <- verbatimStringLiteral; return (Str s, fc)

1246+ <|> do (s, fc) <- stringLiteral; return (Str s, fc)

1247+ <|> do (c, fc) <- try charLiteral; return (Ch c, fc) --Currently ambigous with symbols

12411248 <?> "constant or literal"

12421249

12431250{- | Parses a verbatim multi-line string literal (triple-quoted)

@@ -1248,9 +1255,12 @@ VerbatimString_t ::=

12481255;

12491256@

12501257 -}

1251−verbatimStringLiteral :: MonadicParsing m => m String

1252−verbatimStringLiteral = token $ do try $ string "\"\"\""

1253− manyTill anyChar $ try (string "\"\"\"")

1258+verbatimStringLiteral :: MonadicParsing m => m (String, FC)

1259+verbatimStringLiteral = token $ do (FC f start _) <- getFC

1260+ try $ string "\"\"\""

1261+ str <- manyTill anyChar $ try (string "\"\"\"")

1262+ (FC _ _ end) <- getFC

1263+ return (str, FC f start end)

12541264

12551265{- | Parses a static modifier

12561266

@@ -1317,26 +1327,26 @@ data TacticArg = NameTArg -- ^ Names: n1, n2, n3, ... n

13171327tactics :: [([String], Maybe TacticArg, SyntaxInfo -> IdrisParser PTactic)]

13181328tactics =

13191329 [ (["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)

13211331 , noArgs ["intros"] Intros

13221332 , noArgs ["unfocus"] Unfocus

13231333 , (["refine"], Just ExprTArg, const $

1324− do n <- spaced fnName

1334+ do n <- spaced (fst <$> fnName)

13251335 imps <- many imp

13261336 return $ Refine n imps)

13271337 , (["claim"], Nothing, \syn ->

1328− do n <- indentPropHolds gtProp *> name

1338+ do n <- indentPropHolds gtProp *> (fst <$> name)

13291339 goal <- indentPropHolds gtProp *> expr syn

13301340 return $ Claim n goal)

13311341 , (["mrefine"], Just ExprTArg, const $

1332− do n <- spaced fnName

1342+ do n <- spaced (fst <$> fnName)

13331343 return $ MatchRefine n)

13341344 , expressionTactic ["rewrite"] Rewrite

13351345 , expressionTactic ["case"] CaseTac

13361346 , expressionTactic ["induction"] Induction

13371347 , expressionTactic ["equiv"] Equiv

13381348 , (["let"], Nothing, \syn -> -- FIXME syntax for let

1339− do n <- (indentPropHolds gtProp *> name)

1349+ do n <- (indentPropHolds gtProp *> (fst <$> name))

13401350 (do indentPropHolds gtProp *> lchar ':'

13411351 ty <- indentPropHolds gtProp *> expr' syn

13421352 indentPropHolds gtProp *> lchar '='

@@ -1349,7 +1359,7 @@ tactics =

13491359 return $ LetTac n (desugar syn i t)))

13501360

13511361 , (["focus"], Just ExprTArg, const $

1352− do n <- spaced name

1362+ do n <- spaced (fst <$> name)

13531363 return $ Focus n)

13541364 , expressionTactic ["exact"] Exact

13551365 , expressionTactic ["applyTactic"] ApplyTactic

@@ -1365,7 +1375,7 @@ tactics =

13651375 , noArgs ["trivial"] Trivial

13661376 , noArgs ["unify"] DoUnify

13671377 , (["search"], Nothing, const $

1368− do depth <- option 10 natural

1378+ do depth <- option 10 $ fst <$> natural

13691379 return (ProofSearch True True (fromInteger depth) Nothing []))

13701380 , noArgs ["instance"] TCInstance

13711381 , noArgs ["solve"] Solve

@@ -1381,11 +1391,11 @@ tactics =

13811391 , expressionTactic [":t", ":type"] TCheck

13821392 , expressionTactic [":search"] TSearch

13831393 , (["fail"], Just StringLitTArg, const $

1384− do msg <- stringLiteral

1394+ do msg <- fst <$> stringLiteral

13851395 return $ TFail [Idris.Core.TT.TextPart msg])

13861396 , ([":doc"], Just ExprTArg, const $

13871397 do whiteSpace

1388− doc <- (Right <$> constant) <|> (Left <$> fnName)

1398+ doc <- (Right . fst <$> constant) <|> (Left . fst <$> fnName)

13891399 eof

13901400 return (TDocStr doc))

13911401 ]

src/Idris/ParseHelpers.hs+84−35

@@ -67,6 +67,12 @@ instance TokenParsing IdrisParser where

6767-- | Generalized monadic parsing constraint type

6868type MonadicParsing m = (DeltaParsing m, LookAheadParsing m, TokenParsing m, Monad m)

6969

70+class HasLastTokenSpan m where

71+ getLastTokenSpan :: m (Maybe FC)

72+

73+instance HasLastTokenSpan IdrisParser where

74+ getLastTokenSpan = lastTokenSpan <$> get

75+

7076-- | Helper to run Idris inner parser based stateT parsers

7177runparser :: StateT st IdrisInnerParser res -> st -> String -> String -> Result res

7278runparser p i inputname =

@@ -183,7 +189,7 @@ docComment = do dc <- pushIndent *> docCommentLine

183189 many (satisfy isSpace)

184190 char '@'

185191 many (satisfy isSpace)

186− n <- name

192+ n <- fst <$> name

187193 many (satisfy isSpace)

188194 docs <- many (satisfy (not . isEol))

189195 eol ; someSpace

@@ -194,24 +200,32 @@ whiteSpace :: MonadicParsing m => m ()

194200whiteSpace = Tok.whiteSpace

195201

196202-- | Parses a string literal

197−stringLiteral :: MonadicParsing m => m String

198−stringLiteral = Tok.stringLiteral

203+stringLiteral :: (MonadicParsing m, HasLastTokenSpan m) => m (String, FC)

204+stringLiteral = do str <- Tok.stringLiteral

205+ fc <- getLastTokenSpan

206+ return (str, fromMaybe NoFC fc)

199207

200−-- | Parses a char literal

201−charLiteral :: MonadicParsing m => m Char

202−charLiteral = Tok.charLiteral

208+-- | Parses a char literal

209+charLiteral :: (MonadicParsing m, HasLastTokenSpan m) => m (Char, FC)

210+charLiteral = do ch <- Tok.charLiteral

211+ fc <- getLastTokenSpan

212+ return (ch, fromMaybe NoFC fc)

203213

204214-- | Parses a natural number

205−natural :: MonadicParsing m => m Integer

206−natural = Tok.natural

215+natural :: (MonadicParsing m, HasLastTokenSpan m) => m (Integer, FC)

216+natural = do n <- Tok.natural

217+ fc <- getLastTokenSpan

218+ return (n, fromMaybe NoFC fc)

207219

208220-- | Parses an integral number

209221integer :: MonadicParsing m => m Integer

210222integer = Tok.integer

211223

212224-- | Parses a floating point number

213−float :: MonadicParsing m => m Double

214−float = Tok.double

225+float :: (MonadicParsing m, HasLastTokenSpan m) => m (Double, FC)

226+float = do f <- Tok.double

227+ fc <- getLastTokenSpan

228+ return (f, fromMaybe NoFC fc)

215229

216230{- * Symbols, identifiers, names and operators -}

217231

@@ -250,6 +264,13 @@ symbol = Tok.symbol

250264reserved :: MonadicParsing m => String -> m ()

251265reserved = Tok.reserve idrisStyle

252266

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+

253274-- Taken from Parsec (c) Daan Leijen 1999-2001, (c) Paolo Martini 2007

254275-- | Parses a reserved operator

255276reservedOp :: MonadicParsing m => String -> m ()

@@ -257,37 +278,55 @@ reservedOp name = token $ try $

257278 do string name

258279 notFollowedBy (operatorLetter) <?> ("end of " ++ show name)

259280

260−-- | Parses an identifier as a token

261−identifier :: MonadicParsing m => m String

262−identifier = try(do i <- token $ Tok.ident idrisStyle

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+

287+-- | Parses an identifier as a token

288+identifier :: (MonadicParsing m) => m (String, FC)

289+identifier = try(do (i, fc) <-

290+ token $ do (FC f (l, c) _) <- getFC

291+ i <- Tok.ident idrisStyle

292+ return (i, FC f (l, c) (l, c + length i))

263293 when (i == "_") $ unexpected "wildcard"

264− return i)

294+ return (i, fc))

265295

266296-- | Parses an identifier with possible namespace as a name

267−iName :: MonadicParsing m => [String] -> m Name

268−iName bad = maybeWithNS identifier False bad <?> "name"

297+iName :: (MonadicParsing m, HasLastTokenSpan m) => [String] -> m (Name, FC)

298+iName bad = do (n, fc) <- maybeWithNS identifier False bad

299+ return (n, fc)

300+ <?> "name"

269301

270302-- | 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)

272304maybeWithNS parser ascend bad = do

273− i <- option "" (lookAhead identifier)

305+ fc <- getFC

306+ i <- option "" (lookAhead (fst <$> identifier))

274307 when (i `elem` bad) $ unexpected "reserved identifier"

275308 let transf = if ascend then id else reverse

276− (x, xs) <- choice (transf (parserNoNS parser : parsersNS parser i))

277− return $ mkName (x, xs)

278− where parserNoNS :: MonadicParsing m => m String -> m (String, String)

279− parserNoNS parser = do x <- parser; return (x, "")

280− parserNS :: MonadicParsing m => m String -> String -> m (String, String)

281− parserNS parser ns = do xs <- string ns; lchar '.'; x <- parser; return (x, xs)

282− parsersNS :: MonadicParsing m => m String -> String -> [m (String, String)]

283− parsersNS parser i = [try (parserNS parser ns) | ns <- (initsEndAt (=='.') i)]

309+ (x, xs, fc) <- choice (transf (parserNoNS parser : parsersNS parser i))

310+ return (mkName (x, xs), fc)

311+ where parserNoNS :: MonadicParsing m => m (String, FC) -> m (String, String, FC)

312+ parserNoNS parser = do startFC <- getFC

313+ (x, nameFC) <- parser

314+ return (x, "", spanFC startFC nameFC)

315+ parserNS :: MonadicParsing m => m (String, FC) -> String -> m (String, String, FC)

316+ parserNS parser ns = do startFC <- getFC

317+ xs <- string ns

318+ lchar '.'; (x, nameFC) <- parser

319+ return (x, xs, spanFC startFC nameFC)

320+ parsersNS :: MonadicParsing m => m (String, FC) -> String -> [m (String, String, FC)]

321+ parsersNS parser i = [try (parserNS parser ns) | ns <- (initsEndAt (=='.') i)]

284322

285323-- | Parses a name

286−name :: IdrisParser Name

324+name :: IdrisParser (Name, FC)

287325name = (<?> "name") $ do

288326 keywords <- syntax_keywords <$> get

289327 aliases <- module_aliases <$> get

290− unalias aliases <$> iName keywords

328+ (n, fc) <- iName keywords

329+ return (unalias aliases n, fc)

291330 where

292331 unalias :: M.Map [T.Text] [T.Text] -> Name -> Name

293332 unalias aliases (NS n ns) | Just ns' <- M.lookup ns aliases = NS n ns'

@@ -334,6 +373,15 @@ operator = do op <- token . some $ operatorLetter

334373 fail $ op ++ " is not a valid operator"

335374 return op

336375

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+

337385{- * Position helpers -}

338386{- | Get filename from position (returns "(interactive)" when no source file is given) -}

339387fileName :: Delta -> String

@@ -360,11 +408,12 @@ getFC = do s <- position

360408 -- Issue #1594 on the Issue Tracker.

361409 -- https://github.com/idris-lang/Idris-dev/issues/1594

362410

411+

363412{-* Syntax helpers-}

364413-- | Bind constraints to term

365−bindList :: (Name -> PTerm -> PTerm -> PTerm) -> [(Name, PTerm)] -> PTerm -> PTerm

366−bindList b [] sc = sc

367−bindList b ((n, t):bs) sc = b n t (bindList b bs sc)

414+bindList :: (Name -> FC -> PTerm -> PTerm -> PTerm) -> [(Name, FC, PTerm)] -> PTerm -> PTerm

415+bindList b [] sc = sc

416+bindList b ((n, fc, t):bs) sc = b n fc t (bindList b bs sc)

368417

369418{- * Layout helpers -}

370419

@@ -584,9 +633,9 @@ collect (c@(PClauses _ o _ _) : ds)

584633collect (PParams f ns ps : ds) = PParams f ns (collect ps) : collect ds

585634collect (PMutual f ms : ds) = PMutual f (collect ms) : collect ds

586635collect (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')

588− = PClass doc f s cs n ps pdocs fds (collect ds) cn cd : collect ds'

589−collect (PInstance doc argDocs f s cs n ps t en ds : ds')

590− = PInstance doc argDocs f s cs n ps t en (collect ds) : collect ds'

636+collect (PClass doc f s cs n nfc ps pdocs fds ds cn cd : ds')

637+ = PClass doc f s cs n nfc ps pdocs fds (collect ds) cn cd : collect ds'

638+collect (PInstance doc argDocs f s cs n nfc ps t en ds : ds')

639+ = PInstance doc argDocs f s cs n nfc ps t en (collect ds) : collect ds'

591640collect (d : ds) = d : collect ds

592641collect [] = []

src/Idris/ParseOps.hs+19−12

@@ -29,6 +29,8 @@ import qualified Data.HashSet as HS

2929import qualified Data.Text as T

3030import qualified Data.ByteString.UTF8 as UTF8

3131

32+import Debug.Trace

33+

3234-- | Creates table for fixity declarations to build expression parser

3335-- using pre-build and user-defined operator/fixity declarations

3436table :: [FixDecl] -> OperatorTable IdrisParser PTerm

@@ -45,7 +47,7 @@ table fixes

4547 flatten t = t

4648

4749

48−-- | Calculates table for fixtiy declarations

50+-- | Calculates table for fixity declarations

4951toTable :: [FixDecl] -> OperatorTable IdrisParser PTerm

5052toTable fs = map (map toBin)

5153 (groupBy (\ (Fix x _) (Fix y _) -> prec x == prec y) fs)

@@ -59,9 +61,8 @@ toTable fs = map (map toBin)

5961

6062-- | Binary operator

6163binary :: String -> (FC -> PTerm -> PTerm -> PTerm) -> Assoc -> Operator IdrisParser PTerm

62−binary name f = Infix (do fc <- getFC

63− indentPropHolds gtProp

64− reservedOp name

64+binary name f = Infix (do indentPropHolds gtProp

65+ fc <- reservedOpFC name

6566 indentPropHolds gtProp

6667 return (f fc))

6768

@@ -75,10 +76,9 @@ prefix name f = Prefix (do reservedOp name

7576-- | Backtick operator

7677backtick :: Operator IdrisParser PTerm

7778backtick = Infix (do indentPropHolds gtProp

78− lchar '`'; n <- fnName

79+ lchar '`'; (n, fc) <- fnName

7980 lchar '`'

8081 indentPropHolds gtProp

81− fc <- getFC

8282 return (\x y -> PApp fc (PRef fc n) [pexp x, pexp y])) AssocNone

8383

8484-- | Operator without fixity (throws an error)

@@ -86,7 +86,7 @@ nofixityoperator :: Operator IdrisParser PTerm

8686nofixityoperator = Infix (do indentPropHolds gtProp

8787 op <- try operator

8888 unexpected $ "Operator without known fixity: " ++ op) AssocNone

89−

89+

9090

9191{- | Parses an operator in function position i.e. enclosed by `()', with an

9292 optional namespace

@@ -99,9 +99,15 @@ nofixityoperator = Infix (do indentPropHolds gtProp

9999@

100100

101101-}

102−operatorFront :: IdrisParser Name

103−operatorFront = try ((lchar '(' *> reservedOp "=" <* lchar ')') >> (return eqTy))

104− <|> maybeWithNS (lchar '(' *> operator <* lchar ')') False []

102+operatorFront :: IdrisParser (Name, FC)

103+operatorFront = try (do (FC f (l, c) _) <- getFC

104+ op <- lchar '(' *> reservedOp "=" <* lchar ')'

105+ return (eqTy, FC f (l, c) (l, c+3)))

106+ <|> maybeWithNS (do (FC f (l, c) _) <- getFC

107+ op <- lchar '(' *> operator

108+ (FC _ _ (l', c')) <- getFC

109+ lchar ')'

110+ return (op, (FC f (l, c) (l', c' + 1)))) False []

105111

106112{- | Parses a function (either normal name or operator)

107113

@@ -109,7 +115,7 @@ operatorFront = try ((lchar '(' *> reservedOp "=" <* lchar ')') >> (return eqTy

109115 FnName ::= Name | OperatorFront;

110116@

111117-}

112−fnName :: IdrisParser Name

118+fnName :: IdrisParser (Name, FC)

113119fnName = try operatorFront <|> name <?> "function name"

114120

115121{- | Parses a fixity declaration

@@ -121,7 +127,8 @@ Fixity ::=

121127-}

122128fixity :: IdrisParser PDecl

123129fixity = do pushIndent

124− f <- fixityType; i <- natural; ops <- sepBy1 operator (lchar ',')

130+ f <- fixityType; i <- fst <$> natural;

131+ ops <- sepBy1 operator (lchar ',')

125132 terminator

126133 let prec = fromInteger i

127134 istate <- get

src/Idris/Parser.hs+92−78

@@ -96,7 +96,7 @@ moduleHeader :: IdrisParser (Maybe (Docstring ()), [String])

9696moduleHeader = try (do docs <- optional docComment

9797 noArgs docs

9898 reserved "module"

99− i <- identifier

99+ i <- fst <$> identifier

100100 option ';' (lchar ';')

101101 return (fmap fst docs, moduleName i))

102102 <|> try (do lchar '%'; reserved "unqualified"

@@ -118,8 +118,8 @@ import_ :: IdrisParser (Bool, String, Maybe String, FC)

118118import_ = do fc <- getFC

119119 reserved "import"

120120 reexport <- option False (do reserved "public"; return True)

121− id <- identifier

122− newName <- optional (reserved "as" *> identifier)

121+ id <- fst <$> identifier

122+ newName <- optional (reserved "as" *> (fst <$> identifier))

123123 option ';' (lchar ';')

124124 return (reexport, toPath id, toPath <$> newName, fc)

125125 <?> "import statement"

@@ -310,22 +310,22 @@ syntaxRule syn

310310 return $ PRef fc n'

311311 fixBind rens (PPatvar fc n) | Just n' <- lookup n rens =

312312 return $ PPatvar fc n'

313− fixBind rens (PLam fc n ty body)

314− | n `elem` userNames = liftM2 (PLam fc n) (fixBind rens ty) (fixBind rens body)

313+ fixBind rens (PLam fc n nfc ty body)

314+ | n `elem` userNames = liftM2 (PLam fc n nfc) (fixBind rens ty) (fixBind rens body)

315315 | otherwise =

316316 do ty' <- fixBind rens ty

317317 n' <- gensym n

318318 body' <- fixBind ((n,n'):rens) body

319− return $ PLam fc n' ty' body'

320− fixBind rens (PPi plic n argTy body)

321− | n `elem` userNames = liftM2 (PPi plic n) (fixBind rens argTy) (fixBind rens body)

319+ return $ PLam fc n' nfc ty' body'

320+ fixBind rens (PPi plic n nfc argTy body)

321+ | n `elem` userNames = liftM2 (PPi plic n nfc) (fixBind rens argTy) (fixBind rens body)

322322 | otherwise =

323323 do ty' <- fixBind rens argTy

324324 n' <- gensym n

325325 body' <- fixBind ((n,n'):rens) body

326− return $ (PPi plic n' ty' body')

327− fixBind rens (PLet fc n ty val body)

328− | n `elem` userNames = liftM3 (PLet fc n)

326+ return $ (PPi plic n' nfc ty' body')

327+ fixBind rens (PLet fc n nfc ty val body)

328+ | n `elem` userNames = liftM3 (PLet fc n nfc)

329329 (fixBind rens ty)

330330 (fixBind rens val)

331331 (fixBind rens body)

@@ -334,7 +334,7 @@ syntaxRule syn

334334 val' <- fixBind rens val

335335 n' <- gensym n

336336 body' <- fixBind ((n,n'):rens) body

337− return $ (PLet fc n' ty' val' body')

337+ return $ PLet fc n' nfc ty' val' body'

338338 fixBind rens (PMatchApp fc n) | Just n' <- lookup n rens =

339339 return $ PMatchApp fc n'

340340 fixBind rens x = descendM (fixBind rens) x

@@ -356,13 +356,13 @@ SyntaxSym ::= '[' Name_t ']'

356356@

357357 -}

358358syntaxSym :: IdrisParser SSymbol

359−syntaxSym = try (do lchar '['; n <- name; lchar ']'

359+syntaxSym = try (do lchar '['; n <- fst <$> name; lchar ']'

360360 return (Expr n))

361− <|> try (do lchar '{'; n <- name; lchar '}'

361+ <|> try (do lchar '{'; n <- fst <$> name; lchar '}'

362362 return (Binding n))

363− <|> do n <- iName []

363+ <|> do n <- fst <$> iName []

364364 return (Keyword n)

365− <|> do sym <- stringLiteral

365+ <|> do sym <- fmap fst stringLiteral

366366 return (Symbol sym)

367367 <?> "syntax symbol"

368368

@@ -392,7 +392,7 @@ fnDecl syn = try (do notEndBlock

392392-}

393393fnDecl' :: SyntaxInfo -> IdrisParser PDecl

394394fnDecl' syn = checkFixity $

395− do (doc, argDocs, fc, opts', n, acc) <- try (do

395+ do (doc, argDocs, fc, opts', n, nfc, acc) <- try (do

396396 pushIndent

397397 (doc, argDocs) <- docstring syn

398398 ist <- get

@@ -402,15 +402,15 @@ fnDecl' syn = checkFixity $

402402 opts <- fnOpts initOpts

403403 acc <- optional accessibility

404404 opts' <- fnOpts opts

405− n_in <- fnName

405+ (n_in, nfc) <- fnName

406406 let n = expandNS syn n_in

407407 fc <- getFC

408408 lchar ':'

409− return (doc, argDocs, fc, opts', n, acc))

409+ return (doc, argDocs, fc, opts', n, nfc, acc))

410410 ty <- typeExpr (allowImp syn)

411411 terminator

412412 addAcc n acc

413− return (PTy doc argDocs syn fc opts' n ty)

413+ return (PTy doc argDocs syn fc opts' n nfc ty)

414414 <|> postulate syn

415415 <|> caf syn

416416 <|> pattern syn

@@ -423,7 +423,7 @@ fnDecl' syn = checkFixity $

423423 unless fOk . fail $

424424 "Missing fixity declaration for " ++ show n

425425 return decl

426− getName (PTy _ _ _ _ _ n _) = Just n

426+ getName (PTy _ _ _ _ _ n _ _) = Just n

427427 getName _ = Nothing

428428 fixityOK (NS n _) = fixityOK n

429429 fixityOK (UN n) | all (flip elem opChars) (str n) =

@@ -437,6 +437,7 @@ fnDecl' syn = checkFixity $

437437@

438438FnOpts ::= 'total'

439439 | 'partial'

440+ | 'covering'

440441 | 'implicit'

441442 | '%' 'no_implicit'

442443 | '%' 'assert_total'

@@ -466,7 +467,7 @@ fnOpts opts

466467 = do reserved "total"; fnOpts (TotalFn : opts)

467468 <|> do reserved "partial"; fnOpts (PartialFn : (opts \\ [TotalFn]))

468469 <|> 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;

470471 fnOpts (CExport c : opts)

471472 <|> do try (lchar '%' *> reserved "no_implicit");

472473 fnOpts (NoImplicit : opts)

@@ -489,8 +490,8 @@ fnOpts opts

489490 <|> return opts

490491 <?> "function modifier"

491492 where nameTimes :: IdrisParser (Name, Maybe Int)

492− nameTimes = do n <- fnName

493− t <- option Nothing (do reds <- natural

493+ nameTimes = do n <- fst <$> fnName

494+ t <- option Nothing (do reds <- fmap fst natural

494495 return (Just (fromInteger reds)))

495496 return (n, t)

496497

@@ -515,7 +516,7 @@ postulate syn = do (doc, ext)

515516 opts <- fnOpts initOpts

516517 acc <- optional accessibility

517518 opts' <- fnOpts opts

518− n_in <- fnName

519+ n_in <- fst <$> fnName

519520 let n = expandNS syn n_in

520521 lchar ':'

521522 ty <- typeExpr (allowImp syn)

@@ -555,12 +556,13 @@ Params ::=

555556params :: SyntaxInfo -> IdrisParser [PDecl]

556557params syn =

557558 do reserved "parameters"; lchar '('; ns <- typeDeclList syn; lchar ')'

559+ let ns' = [(n, ty) | (n, _, ty) <- ns]

558560 openBlock

559561 let pvars = syn_params syn

560− ds <- many (decl syn { syn_params = pvars ++ ns })

562+ ds <- many (decl syn { syn_params = pvars ++ ns' })

561563 closeBlock

562564 fc <- getFC

563− return [PParams fc ns (concat ds)]

565+ return [PParams fc ns' (concat ds)]

564566 <?> "parameters declaration"

565567

566568{- | Parses a mutual declaration (for mutually recursive functions)

@@ -592,7 +594,7 @@ Namespace ::=

592594-}

593595namespace :: SyntaxInfo -> IdrisParser [PDecl]

594596namespace syn =

595− do reserved "namespace"; n <- identifier;

597+ do reserved "namespace"; n <- fst <$> identifier

596598 openBlock

597599 ds <- some (decl syn { syn_namespace = n : syn_namespace syn })

598600 closeBlock

@@ -628,7 +630,7 @@ ClassBlock ::=

628630 ;

629631@

630632-}

631−classBlock :: SyntaxInfo -> IdrisParser (Maybe Name, Docstring (Either Err PTerm), [PDecl])

633+classBlock :: SyntaxInfo -> IdrisParser (Maybe (Name, FC), Docstring (Either Err PTerm), [PDecl])

632634classBlock syn = do reserved "where"

633635 openBlock

634636 (cn, cd) <- option (Nothing, emptyDocstring) $

@@ -644,7 +646,7 @@ classBlock syn = do reserved "where"

644646 <?> "class block"

645647

646648 where

647− constructor :: IdrisParser Name

649+ constructor :: IdrisParser (Name, FC)

648650 constructor = reserved "constructor" *> fnName

649651

650652 annotate :: SyntaxInfo -> IState -> Docstring () -> Docstring (Either Err PTerm)

@@ -673,23 +675,25 @@ class_ syn = do (doc, argDocs, acc)

673675 return (doc, argDocs, acc))

674676 fc <- getFC

675677 cons <- constraintList syn

676− n_in <- fnName

678+ let cons' = [(c, ty) | (c, _, ty) <- cons]

679+ (n_in, nfc) <- fnName

677680 let n = expandNS syn n_in

678681 cs <- many carg

679− fds <- option (map fst cs) fundeps

682+ fds <- option [(cn, NoFC) | (cn, _, _) <- cs] fundeps

680683 (cn, cd, ds) <- option (Nothing, fst noDocs, []) (classBlock syn)

681684 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]

683686 <?> "type-class declaration"

684687 where

685− fundeps :: IdrisParser [Name]

688+ fundeps :: IdrisParser [(Name, FC)]

686689 fundeps = do lchar '|'; sepBy name (lchar ',')

687690

688− carg :: IdrisParser (Name, PTerm)

689− carg = do lchar '('; i <- name; lchar ':'; ty <- expr syn; lchar ')'

690− return (i, ty)

691− <|> do i <- name;

692− return (i, PType)

691+ carg :: IdrisParser (Name, FC, PTerm)

692+ carg = do lchar '('; (i, ifc) <- name; lchar ':'; ty <- expr syn; lchar ')'

693+ return (i, ifc, ty)

694+ <|> do (i, ifc) <- name

695+ fc <- getFC

696+ return (i, ifc, PType fc)

693697

694698{- | Parses a type class instance declaration

695699

@@ -709,15 +713,16 @@ instance_ syn = do (doc, argDocs)

709713 fc <- getFC

710714 en <- optional instanceName

711715 cs <- constraintList syn

712− cn <- fnName

716+ let cs' = [(c, ty) | (c, _, ty) <- cs]

717+ (cn, cnfc) <- fnName

713718 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)

715720 let t = bindList (PPi constraint) cs sc

716721 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]

718723 <?> "instance declaration"

719724 where instanceName :: IdrisParser Name

720− instanceName = do lchar '['; n_in <- fnName; lchar ']'

725+ instanceName = do lchar '['; n_in <- fst <$> fnName; lchar ']'

721726 let n = expandNS syn n_in

722727 return n

723728 <?> "instance name"

@@ -761,7 +766,7 @@ NameList ::=

761766usingDeclList :: SyntaxInfo -> IdrisParser [Using]

762767usingDeclList syn

763768 = try (sepBy1 (usingDecl syn) (lchar ','))

764− <|> do ns <- sepBy1 name (lchar ',')

769+ <|> do ns <- sepBy1 (fst <$> name) (lchar ',')

765770 lchar ':'

766771 t <- typeExpr (disallowImp syn)

767772 return (map (\x -> UImplicit x t) ns)

@@ -777,12 +782,12 @@ UsingDecl ::=

777782@

778783-}

779784usingDecl :: SyntaxInfo -> IdrisParser Using

780−usingDecl syn = try (do x <- fnName

785+usingDecl syn = try (do x <- fst <$> fnName

781786 lchar ':'

782787 t <- typeExpr (disallowImp syn)

783788 return (UImplicit x t))

784− <|> do c <- fnName

785− xs <- some fnName

789+ <|> do c <- fst <$> fnName

790+ xs <- some (fst <$> fnName)

786791 return (UConstraint c xs)

787792 <?> "using declaration"

788793

@@ -806,7 +811,7 @@ CAF ::= 'let' FnName '=' Expr Terminator;

806811-}

807812caf :: SyntaxInfo -> IdrisParser PDecl

808813caf 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

810815 lchar '='

811816 t <- expr syn

812817 terminator

@@ -842,7 +847,7 @@ rhs :: SyntaxInfo -> Name -> IdrisParser PTerm

842847rhs syn n = do lchar '='; expr syn

843848 <|> do symbol "?=";

844849 fc <- getFC

845− name <- option n' (do symbol "{"; n <- fnName; symbol "}";

850+ name <- option n' (do symbol "{"; n <- fst <$> fnName; symbol "}";

846851 return n)

847852 r <- expr syn

848853 return (addLet fc name r)

@@ -856,10 +861,10 @@ rhs syn n = do lchar '='; expr syn

856861 n' :: Name

857862 n' = mkN n

858863 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)

860865 addLet fc nm (PCase fc' t cs) = PCase fc' t (map addLetC cs)

861866 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))

863868

864869{- |Parses a function clause

865870

@@ -916,7 +921,7 @@ clause syn

916921 symbol "<=="

917922 return ty)

918923 fc <- getFC

919− n_in <- fnName; let n = expandNS syn n_in

924+ n_in <- fst <$> fnName; let n = expandNS syn n_in

920925 r <- rhs syn n

921926 ist <- get

922927 let ctxt = tt_ctxt ist

@@ -926,20 +931,20 @@ clause syn

926931 return x,

927932 do terminator

928933 return ([], [])]

929− let capp = PLet fc (sMN 0 "match")

934+ let capp = PLet fc (sMN 0 "match") NoFC

930935 ty

931936 (PMatchApp fc n)

932937 (PRef fc (sMN 0 "match"))

933938 ist <- get

934939 put (ist { lastParse = Just n })

935940 return $ PClause fc n capp [] r wheres

936− <|> do (l, op) <- try (do

941+ <|> do (l, op, nfc) <- try (do

937942 pushIndent

938943 l <- argExpr syn

939− op <- operator

944+ (op, nfc) <- operatorFC

940945 when (op == "=" || op == "?=" ) $

941946 fail "infix clause definition with \"=\" and \"?=\" not supported "

942− return (l, op))

947+ return (l, op, nfc))

943948 let n = expandNS syn (sUN op)

944949 r <- argExpr syn

945950 fc <- getFC

@@ -952,7 +957,7 @@ clause syn

952957 do terminator

953958 return ([], [])]

954959 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]

956961 put (ist { lastParse = Just n })

957962 return $ PClause fc n capp wargs rs wheres) <|> (do

958963 popIndent

@@ -968,13 +973,13 @@ clause syn

968973 put (ist { lastParse = Just n })

969974 return $ PWith fc n capp wargs wval pn withs)

970975 <|> do pushIndent

971− n_in <- fnName; let n = expandNS syn n_in

976+ (n_in, nfc) <- fnName; let n = expandNS syn n_in

972977 cargs <- many (constraintArg syn)

973978 fc <- getFC

974979 args <- many (try (implicitArg (syn { inPattern = True } ))

975980 <|> (fmap pexp (argExpr syn)))

976981 wargs <- many (wExpr syn)

977− let capp = PApp fc (PRef fc n)

982+ let capp = PApp fc (PRef nfc n)

978983 (cargs ++ args)

979984 (do r <- rhs syn n

980985 ist <- get

@@ -1055,7 +1060,8 @@ Codegen ::= 'C'

10551060@

10561061-}

10571062codegen_ :: IdrisParser Codegen

1058−codegen_ = do n <- identifier; return (Via (map toLower n))

1063+codegen_ = do n <- fst <$> identifier

1064+ return (Via (map toLower n))

10591065 <|> do reserved "Bytecode"; return Bytecode

10601066 <?> "code generation language"

10611067

@@ -1090,17 +1096,23 @@ Directive' ::= 'lib' CodeGen String_t

10901096@

10911097-}

10921098directive :: 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

10941102 return [PDirective (DLib cgn lib)]

1095− <|> do try (lchar '%' *> reserved "link"); cgn <- codegen_; obj <- stringLiteral;

1103+ <|> do try (lchar '%' *> reserved "link")

1104+ cgn <- codegen_; obj <- fst <$> stringLiteral

10961105 return [PDirective (DLink cgn obj)]

1097− <|> do try (lchar '%' *> reserved "flag"); cgn <- codegen_; flag <- stringLiteral

1106+ <|> do try (lchar '%' *> reserved "flag")

1107+ cgn <- codegen_; flag <- fst <$> stringLiteral

10981108 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

11001112 return [PDirective (DInclude cgn hdr)]

1101− <|> do try (lchar '%' *> reserved "hide"); n <- fnName

1113+ <|> do try (lchar '%' *> reserved "hide"); n <- fst <$> fnName

11021114 return [PDirective (DHide n)]

1103− <|> do try (lchar '%' *> reserved "freeze"); n <- iName []

1115+ <|> do try (lchar '%' *> reserved "freeze"); n <- fst <$> iName []

11041116 return [PDirective (DFreeze n)]

11051117 <|> do try (lchar '%' *> reserved "access"); acc <- accessibility

11061118 return [PDirective (DAccess acc)]

@@ -1108,25 +1120,27 @@ directive syn = do try (lchar '%' *> reserved "lib"); cgn <- codegen_; lib <- st

11081120 i <- get

11091121 put (i { default_total = tot } )

11101122 return [PDirective (DDefault tot)]

1111− <|> do try (lchar '%' *> reserved "logging"); i <- natural;

1123+ <|> do try (lchar '%' *> reserved "logging")

1124+ i <- fst <$> natural

11121125 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 ',')

11141128 return [PDirective (DDynamicLibs libs)]

11151129 <|> do try (lchar '%' *> reserved "name")

1116− ty <- fnName

1117− ns <- sepBy1 name (lchar ',')

1130+ ty <- fst <$> fnName

1131+ ns <- sepBy1 (fst <$> name) (lchar ',')

11181132 return [PDirective (DNameHint ty ns)]

11191133 <|> do try (lchar '%' *> reserved "error_handlers")

1120− fn <- fnName

1121− arg <- fnName

1122− ns <- sepBy1 name (lchar ',')

1134+ fn <- fst <$> fnName

1135+ arg <- fst <$> fnName

1136+ ns <- sepBy1 (fst <$> name) (lchar ',')

11231137 return [PDirective (DErrorHandlers fn arg ns) ]

11241138 <|> do try (lchar '%' *> reserved "language"); ext <- pLangExt;

11251139 return [PDirective (DLanguage ext)]

11261140 <|> do fc <- getFC

11271141 try (lchar '%' *> reserved "used")

1128− fn <- fnName

1129− arg <- iName []

1142+ fn <- fst <$> fnName

1143+ arg <- fst <$> iName []

11301144 return [PDirective (DUsed fc fn arg)]

11311145 <?> "directive"

11321146

@@ -1161,14 +1175,14 @@ provider syn = do doc <- try (do (doc, _) <- docstring syn

11611175 provideTerm doc <|> providePostulate doc

11621176 <?> "type provider"

11631177 where provideTerm doc =

1164− do lchar '('; n <- fnName; lchar ':'; t <- typeExpr syn; lchar ')'

1178+ do lchar '('; n <- fst <$> fnName; lchar ':'; t <- typeExpr syn; lchar ')'

11651179 fc <- getFC

11661180 reserved "with"

11671181 e <- expr syn <?> "provider expression"

11681182 return [PProvider doc syn fc (ProvTerm t e) n]

11691183 providePostulate doc =

11701184 do reserved "postulate"

1171− n <- fnName

1185+ n <- fst <$> fnName

11721186 fc <- getFC

11731187 reserved "with"

11741188 e <- expr syn <?> "provider expression"

@@ -1201,7 +1215,7 @@ parseExpr st = runparser (fullExpr defaultSyntax) st "(input)"

12011215

12021216{- | Parses a constant form input -}

12031217parseConst :: IState -> String -> Result Const

1204−parseConst st = runparser constant st "(input)"

1218+parseConst st = runparser (fmap fst constant) st "(input)"

12051219

12061220{- | Parses a tactic from input -}

12071221parseTactic :: IState -> String -> Result PTactic

src/Idris/PartialEval.hs+3−3

@@ -128,12 +128,12 @@ mkPE_TyDecl :: IState -> [(PEArgType, Term)] -> Type -> PTerm

128128mkPE_TyDecl ist args ty = mkty args ty

129129 where

130130 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)

132132 mkty ((ImplicitD, v) : xs) (Bind n (Pi _ t k) sc)

133133 | concreteClass ist t = mkty xs sc

134134 | classConstraint ist t

135− = PPi constraint n (delab ist (generaliseIn t)) (mkty xs sc)

136− | otherwise = PPi impl 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 NoFC (delab ist (generaliseIn t)) (mkty xs sc)

137137

138138 mkty (_ : xs) t

139139 = mkty xs t

src/Idris/Prover.hs+1−1

@@ -297,7 +297,7 @@ ploop fn d prompt prf e h

297297 infixes = idris_infixes ist

298298 action = case tm of

299299 TType _ ->

300− iPrintTermWithType (prettyImp ppo PType) type1Doc

300+ iPrintTermWithType (prettyImp ppo (PType emptyFC)) type1Doc

301301 _ -> let bnd = map (\x -> (fst x, False)) env in

302302 iPrintTermWithType (pprintPTerm ppo bnd [] infixes (delab ist tm))

303303 (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) =

438438 in

439439 displaySpans .

440440 renderPretty 0.9 cols .

441− fmap (fancifyAnnots ist) .

441+ fmap (fancifyAnnots ist True) .

442442 annotate (AnnTerm (zip bnd (take (length bnd) (repeat False))) t) $

443443 prettyT

444444

@@ -463,7 +463,7 @@ runIdeModeCommand h id orig fn mods (IdeMode.WhoCalls n) =

463463 runIO . hPutStrLn h $ IdeMode.convSExp "return" msg id

464464 where pn ist = displaySpans .

465465 renderPretty 0.9 1000 .

466− fmap (fancifyAnnots ist) .

466+ fmap (fancifyAnnots ist True) .

467467 prettyName True True []

468468

469469runIdeModeCommand h id orig fn mods (IdeMode.CallsWho n) =

@@ -476,7 +476,7 @@ runIdeModeCommand h id orig fn mods (IdeMode.CallsWho n) =

476476 runIO . hPutStrLn h $ IdeMode.convSExp "return" msg id

477477 where pn ist = displaySpans .

478478 renderPretty 0.9 1000 .

479− fmap (fancifyAnnots ist) .

479+ fmap (fancifyAnnots ist True) .

480480 prettyName True True []

481481

482482runIdeModeCommand h id orig fn modes (IdeMode.BrowseNS ns) =

@@ -491,7 +491,7 @@ runIdeModeCommand h id orig fn modes (IdeMode.BrowseNS ns) =

491491 runIO . hPutStrLn h $ IdeMode.convSExp "return" msg id

492492 where pn ist = displaySpans .

493493 renderPretty 0.9 1000 .

494− fmap (fancifyAnnots ist) .

494+ fmap (fancifyAnnots ist True) .

495495 prettyName True True []

496496runIdeModeCommand h id orig fn modes (IdeMode.TermNormalise bnd tm) =

497497 do ctxt <- getContext

@@ -506,7 +506,7 @@ runIdeModeCommand h id orig fn modes (IdeMode.TermNormalise bnd tm) =

506506 msg = (IdeMode.SymbolAtom "ok",

507507 displaySpans .

508508 renderPretty 0.9 80 .

509− fmap (fancifyAnnots ist) $ ptm)

509+ fmap (fancifyAnnots ist True) $ ptm)

510510 runIO . hPutStrLn h $ IdeMode.convSExp "return" msg id

511511runIdeModeCommand h id orig fn modes (IdeMode.TermShowImplicits bnd tm) =

512512 ideModeForceTermImplicits h id bnd True tm

@@ -519,7 +519,7 @@ runIdeModeCommand h id orig fn modes (IdeMode.TermElab bnd tm) =

519519 msg = (IdeMode.SymbolAtom "ok",

520520 displaySpans .

521521 renderPretty 0.9 70 .

522− fmap (fancifyAnnots ist) $ ptm)

522+ fmap (fancifyAnnots ist True) $ ptm)

523523 runIO . hPutStrLn h $ IdeMode.convSExp "return" msg id

524524runIdeModeCommand h id orig fn mods (IdeMode.PrintDef name) =

525525 case splitName name of

@@ -535,7 +535,7 @@ runIdeModeCommand h id orig fn modes (IdeMode.ErrPPrint e) =

535535 let (out, spans) =

536536 displaySpans .

537537 renderPretty 0.9 80 .

538− fmap (fancifyAnnots ist) $ pprintErr ist e

538+ fmap (fancifyAnnots ist True) $ pprintErr ist e

539539 msg = (IdeMode.SymbolAtom "ok", out, spans)

540540 runIO . hPutStrLn h $ IdeMode.convSExp "return" msg id

541541runIdeModeCommand h id orig fn modes IdeMode.GetIdrisVersion =

@@ -558,7 +558,7 @@ ideModeForceTermImplicits h id bnd impl tm =

558558 msg = (IdeMode.SymbolAtom "ok",

559559 displaySpans .

560560 renderPretty 0.9 80 .

561− fmap (fancifyAnnots ist) $ expl)

561+ fmap (fancifyAnnots ist True) $ expl)

562562 runIO . hPutStrLn h $ IdeMode.convSExp "return" msg id

563563

564564splitName :: String -> Either String Name

@@ -788,16 +788,16 @@ process fn (NewDefn decls) = do

788788 mapM_ defineName namedGroups where

789789 namedGroups = groupBy (\d1 d2 -> getName d1 == getName d2) decls

790790 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

792792 getName (PClauses fc opts name (clause:clauses)) = Just (getClauseName clause)

793793 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

795795 getName _ = Nothing

796796 -- getClauseName is partial and I am not sure it's used safely! -- trillioneyes

797797 getClauseName (PClause fc name whole with rhs whereBlock) = name

798798 getClauseName (PWith fc name whole with rhs pn whereBlock) = name

799799 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

801801 elabDecl EAll recinfo tyDecl

802802 elabClauses recinfo fc opts name (concatMap getClauses decls)

803803 setReplDefined (Just name)

@@ -839,8 +839,8 @@ process fn (NewDefn decls) = do

839839 fixClauses :: PDecl' t -> PDecl' t

840840 fixClauses (PClauses fc opts _ css@(clause:cs)) =

841841 PClauses fc opts (getClauseName clause) css

842− fixClauses (PInstance doc argDocs syn fc constraints cls parms ty instName decls) =

843− PInstance doc argDocs syn fc constraints cls parms ty instName (map fixClauses decls)

842+ fixClauses (PInstance doc argDocs syn fc constraints cls nfc parms ty instName decls) =

843+ PInstance doc argDocs syn fc constraints cls nfc parms ty instName (map fixClauses decls)

844844 fixClauses decl = decl

845845

846846process fn (Undefine names) = undefine names

@@ -896,7 +896,7 @@ process fn (Check (PRef _ n))

896896 case lookupNames n ctxt of

897897 ts@(t:_) ->

898898 case lookup t (idris_metavars ist) of

899− Just (_, i, _) -> iRenderResult . fmap (fancifyAnnots ist) $

899+ Just (_, i, _) -> iRenderResult . fmap (fancifyAnnots ist True) $

900900 showMetavarInfo ppo ist n i

901901 Nothing -> iPrintFunTypes [] n (map (\n -> (n, pprintDelabTy ist n)) ts)

902902 [] -> iPrintError $ "No such variable " ++ show n

@@ -906,7 +906,7 @@ process fn (Check (PRef _ n))

906906 (ty:_) -> putTy ppo ist i [] (delab ist (errReverse ist ty))

907907 putTy :: PPOption -> IState -> Int -> [(Name, Bool)] -> PTerm -> Doc OutputAnnotation

908908 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)

910910 = let current = text " " <>

911911 (case n of

912912 MN _ _ -> text "_"

@@ -932,7 +932,7 @@ process fn (Check t)

932932 ty' = normaliseC ctxt [] ty

933933 case tm of

934934 TType _ ->

935− iPrintTermWithType (prettyIst ist PType) type1Doc

935+ iPrintTermWithType (prettyIst ist (PType emptyFC)) type1Doc

936936 _ -> iPrintTermWithType (pprintDelab ist tm)

937937 (pprintDelab ist ty)

938938

@@ -1293,7 +1293,7 @@ process fn (Browse ns) =

12931293process fn (MakeDoc s) =

12941294 do istate <- getIState

12951295 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

12971297 parse n = Left n

12981298 (bad, nss) = partitionEithers $ map parse names

12991299 cd <- runIO $ getCurrentDirectory

src/Idris/REPLParser.hs+26−25

@@ -212,19 +212,19 @@ genArg argName argParser cmd name = do

212212 failure = return $ Left ("Usage is :" ++ name ++ " <" ++ argName ++ ">")

213213

214214nameArg, fnNameArg :: (Name -> Command) -> String -> P.IdrisParser (Either String Command)

215−nameArg = genArg "name" P.name

216−fnNameArg = genArg "functionname" P.fnName

215+nameArg = genArg "name" $ fst <$> P.name

216+fnNameArg = genArg "functionname" $ fst <$> P.fnName

217217

218218strArg :: (String -> Command) -> String -> P.IdrisParser (Either String Command)

219219strArg = genArg "string" (many anyChar)

220220

221221moduleArg :: (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)

223223 where

224224 toPath n = foldl1' (</>) $ splitOn "." n

225225

226226namespaceArg :: ([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)

228228 where

229229 toNS = splitOn "."

230230

@@ -258,14 +258,14 @@ proofArg cmd name = do

258258 upd <- option False $ do

259259 P.lchar '!'

260260 return True

261− l <- P.natural

262− n <- P.name;

261+ l <- fst <$> P.natural

262+ n <- fst <$> P.name;

263263 return (Right (cmd upd (fromInteger l) n))

264264

265265cmd_doc :: String -> P.IdrisParser (Either String Command)

266266cmd_doc name = do

267267 let constant = do

268− c <- P.constant

268+ c <- fmap fst P.constant

269269 eof

270270 return $ Right (DocStr (Right c) FullDocs)

271271

@@ -282,7 +282,8 @@ cmd_consolewidth name = do

282282 pConsoleWidth :: P.IdrisParser ConsoleWidth

283283 pConsoleWidth = do discard (P.symbol "auto"); return AutomaticWidth

284284 <|> 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)

286287

287288cmd_execute :: String -> P.IdrisParser (Either String Command)

288289cmd_execute name = do

@@ -307,7 +308,7 @@ cmd_pprint :: String -> P.IdrisParser (Either String Command)

307308cmd_pprint name = do

308309 fmt <- ppFormat

309310 P.whiteSpace

310− n <- fmap fromInteger P.natural

311+ n <- fmap (fromInteger . fst) P.natural

311312 P.whiteSpace

312313 t <- P.fullExpr defaultSyntax

313314 return (Right (PPrint fmt n t))

@@ -326,20 +327,20 @@ cmd_compile name = do

326327 let codegenOption :: P.IdrisParser Codegen

327328 codegenOption = do

328329 let bytecodeCodegen = discard (P.symbol "bytecode") *> return Bytecode

329− viaCodegen = do x <- P.identifier

330+ viaCodegen = do x <- fst <$> P.identifier

330331 return (Via (map toLower x))

331332 bytecodeCodegen <|> viaCodegen

332333

333334 let hasOneArg = do

334335 i <- get

335− f <- P.identifier

336+ f <- fst <$> P.identifier

336337 eof

337338 return $ Right (Compile defaultCodegen f)

338339

339340 let hasTwoArgs = do

340341 i <- get

341342 codegen <- codegenOption

342− f <- P.identifier

343+ f <- fst <$> P.identifier

343344 eof

344345 return $ Right (Compile codegen f)

345346

@@ -349,16 +350,16 @@ cmd_compile name = do

349350cmd_addproof :: String -> P.IdrisParser (Either String Command)

350351cmd_addproof name = do

351352 n <- option Nothing $ do

352− x <- P.name;

353+ x <- fst <$> P.name

353354 return (Just x)

354355 eof

355356 return (Right (AddProof n))

356357

357358cmd_log :: String -> P.IdrisParser (Either String Command)

358359cmd_log name = do

359− i <- P.natural

360+ i <- fmap (fromIntegral . fst) P.natural

360361 eof

361− return (Right (LogLvl (fromIntegral i)))

362+ return (Right (LogLvl i))

362363

363364cmd_let :: String -> P.IdrisParser (Either String Command)

364365cmd_let name = do

@@ -366,13 +367,13 @@ cmd_let name = do

366367 return (Right (NewDefn defn))

367368

368369cmd_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)

370371

371372cmd_loadto :: String -> P.IdrisParser (Either String Command)

372373cmd_loadto name = do

373− toline <- P.natural

374+ toline <- fmap (fromInteger . fst) P.natural

374375 f <- many anyChar;

375− return (Right (Load f (Just (fromInteger toline))))

376+ return (Right (Load f (Just toline)))

376377

377378cmd_colour :: String -> P.IdrisParser (Either String Command)

378379cmd_colour name = fmap Right pSetColourCmd

@@ -452,19 +453,19 @@ packageBasedCmd valParser cmd name = do

452453 return (Right (cmd pkgs val))

453454

454455cmd_search :: String -> P.IdrisParser (Either String Command)

455−cmd_search = packageBasedCmd

456+cmd_search = packageBasedCmd

456457 (P.typeExpr (defaultSyntax { implicitAllowed = True })) Search

457458

458459cmd_proofsearch :: String -> P.IdrisParser (Either String Command)

459460cmd_proofsearch name = do

460461 upd <- option False (do P.lchar '!'; return True)

461− l <- P.natural; n <- P.name;

462− hints <- many P.fnName

463− return (Right (DoProofSearch upd True (fromInteger l) n hints))

462+ l <- fmap (fromInteger . fst) P.natural; n <- fst <$> P.name

463+ hints <- many (fst <$> P.fnName)

464+ return (Right (DoProofSearch upd True l n hints))

464465

465466cmd_refine :: String -> P.IdrisParser (Either String Command)

466467cmd_refine name = do

467468 upd <- option False (do P.lchar '!'; return True)

468− l <- P.natural; n <- P.name;

469− hint <- P.fnName

470− return (Right (DoProofSearch upd False (fromInteger l) n [hint]))

469+ l <- fmap (fromInteger . fst) P.natural; n <- fst <$> P.name

470+ hint <- fst <$> P.fnName

471+ return (Right (DoProofSearch upd False l n [hint]))

src/Idris/TypeSearch.hs+1−1

@@ -47,7 +47,7 @@ searchByType pkgs pterm = do

4747 pterm' <- addUsingConstraints syn emptyFC pterm

4848 pterm'' <- implicit toplevel syn name pterm'

4949 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'

5151 let names = searchUsing searchPred i ty

5252 let names' = take numLimit names

5353 let docs =

src/Pkg/PParser.hs+13−10

@@ -5,12 +5,12 @@

66module 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)

1010import Idris.Core.TT

1111import Idris.REPL

1212import Idris.AbsSyntaxTree

13−import Idris.ParseHelpers

13+import Idris.ParseHelpers hiding (stringLiteral)

1414import Idris.CmdOptions

1515

1616import Control.Monad.State.Strict

@@ -34,6 +34,9 @@ data PkgDesc = PkgDesc { pkgname :: String,

3434 }

3535 deriving Show

3636

37+instance HasLastTokenSpan PParser where

38+ getLastTokenSpan = return Nothing

39+

3740#if MIN_VERSION_base(4,8,0)

3841instance {-# OVERLAPPING #-} TokenParsing PParser where

3942#else

@@ -51,7 +54,7 @@ parseDesc fp = do p <- readFile fp

5154 Success x -> return x

5255

5356pPkg :: PParser PkgDesc

54−pPkg = do reserved "package"; p <- identifier

57+pPkg = do reserved "package"; p <- fst <$> identifier

5558 st <- get

5659 put (st { pkgname = p })

5760 some pClause

@@ -68,11 +71,11 @@ pClause = do reserved "executable"; lchar '=';

6871 else ( show exec )

6972 ) })

7073 <|> do reserved "main"; lchar '=';

71− main <- iName []

74+ main <- fst <$> iName []

7275 st <- get

7376 put (st { idris_main = main })

7477 <|> do reserved "sourcedir"; lchar '=';

75− src <- identifier

78+ src <- fst <$> identifier

7679 st <- get

7780 put (st { sourcedir = src })

7881 <|> do reserved "opts"; lchar '=';

@@ -81,23 +84,23 @@ pClause = do reserved "executable"; lchar '=';

8184 let args = pureArgParser (words opts)

8285 put (st { idris_opts = args })

8386 <|> do reserved "modules"; lchar '=';

84− ms <- sepBy1 (iName []) (lchar ',')

87+ ms <- sepBy1 (fst <$> iName []) (lchar ',')

8588 st <- get

8689 put (st { modules = modules st ++ ms })

8790 <|> do reserved "libs"; lchar '=';

88− ls <- sepBy1 identifier (lchar ',')

91+ ls <- sepBy1 (fst <$> identifier) (lchar ',')

8992 st <- get

9093 put (st { libdeps = libdeps st ++ ls })

9194 <|> do reserved "objs"; lchar '=';

92− ls <- sepBy1 identifier (lchar ',')

95+ ls <- sepBy1 (fst <$> identifier) (lchar ',')

9396 st <- get

9497 put (st { objs = libdeps st ++ ls })

9598 <|> do reserved "makefile"; lchar '=';

96− mk <- iName []

99+ mk <- fst <$> iName []

97100 st <- get

98101 put (st { makefile = Just (show mk) })

99102 <|> do reserved "tests"; lchar '=';

100− ts <- sepBy1 (iName []) (lchar ',')

103+ ts <- sepBy1 (fst <$> iName []) (lchar ',')

101104 st <- get

102105 put st { idris_tests = idris_tests st ++ ts }

103106

test/reg007/expected+1−1

@@ -1,5 +1,5 @@

11reg007.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:

33Can't unify

44 n = lala (Type of isSame)

55with

test/sourceLocation001/expected+2−2

@@ -1,11 +1,11 @@

11Testing using definition

2−FileLoc "SourceLoc.idr" (16, 11) (16, 11)

2+FileLoc "SourceLoc.idr" (16, 11) (16, 17)

33Testing using inline tactics

44FileLoc "SourceLoc.idr" (20, 17) (20, 17)

55Testing using metavariable with later definition

66FileLoc "SourceLoc.idr" (98, 16) (98, 16)

77-----------------------

88Success!

9−Error at FileLoc "SourceLoc.idr" (72, 23) (72, 23)

9+Error at FileLoc "SourceLoc.idr" (72, 23) (72, 26)

1010Success!

1111Success!

test/tutorial006/expected+2−1

@@ -1,4 +1,5 @@

1−tutorial006a.idr:5:23:When elaborating right hand side of vapp:

1+tutorial006a.idr:5:23-25:

2+When elaborating right hand side of vapp:

23When elaborating argument xs to constructor Data.VectType.Vect.:::

34 Can't unify

45 Vect (n + n) a (Type of vapp xs xs)