Merge pull request #1354 from ucsd-progsys/json-types

Add span-support in JSON

Author: ranjitjhala

liquid-fixpoint

@@ -10,6 +10,7 @@ module Language.Haskell.Liquid.UX.ACSS (
   ) where
 
 import Prelude hiding (error)
+import qualified SrcLoc 
 
 import Language.Haskell.HsColour.Anchors
 import Language.Haskell.HsColour.Classify as Classify
@@ -25,10 +26,11 @@ import Text.Printf
 import Language.Haskell.Liquid.GHC.Misc
 import Language.Haskell.Liquid.Types.Errors (panic, impossible)
 
-data AnnMap  = Ann {
-    types  :: M.HashMap Loc (String, String) -- ^ Loc -> (Var, Type)
-  , errors :: [(Loc, Loc, String)]           -- ^ List of error intervals
-  , status :: !Status
+data AnnMap  = Ann 
+  { types   :: M.HashMap Loc (String, String) -- ^ Loc -> (Var, Type)
+  , errors  :: [(Loc, Loc, String)]           -- ^ List of error intervals
+  , status  :: !Status
+  , sptypes :: ![(SrcLoc.RealSrcSpan, (String, String)) ]-- ^ Type information with spans
   }
 
 data Status = Safe | Unsafe | Error | Crash
@@ -93,7 +95,7 @@ annotTokenise baseLoc tx (src, annm) = zipWith (\(x,y) z -> (x,y,z)) toks annots
     linWidth   = length $ show $ length $ lines src
 
 spanAnnot :: Int -> AnnMap -> Loc -> Annotation
-spanAnnot w (Ann ts es _) span = A t e b
+spanAnnot w (Ann ts es _ _) span = A t e b
   where
     t = fmap snd (M.lookup span ts)
     e = fmap (\_ -> "ERROR") $ find (span `inRange`) [(x,y) | (x,y,_) <- es]
@@ -177,7 +179,7 @@ splitSrcAndAnns ::  String -> (String, AnnMap)
 splitSrcAndAnns s =
   let ls = lines s in
   case findIndex (breakS ==) ls of
-    Nothing -> (s, Ann M.empty [] Safe)
+    Nothing -> (s, Ann M.empty [] Safe mempty)
     Just i  -> (src, ann)
                where (codes, _:mname:annots) = splitAt i ls
                      ann   = annotParse mname $ dropWhile isSpace $ unlines annots
@@ -198,7 +200,7 @@ breakS :: [Char]
 breakS = "MOUSEOVER ANNOTATIONS"
 
 annotParse :: String -> String -> AnnMap
-annotParse mname s = Ann (M.fromList ts) [(x,y,"") | (x,y) <- es] Safe
+annotParse mname s = Ann (M.fromList ts) [(x,y,"") | (x,y) <- es] Safe mempty
   where
     (ts, es)       = partitionEithers $ parseLines mname 0 $ lines s
 
@@ -235,8 +237,9 @@ parseLines _ i _
   = panic Nothing $ "Error Parsing Annot Input on Line: " ++ show i
 
 instance Show AnnMap where
-  show (Ann ts es _ ) =  "\n\n" ++ (concatMap ppAnnotTyp $ M.toList ts)
-                                ++ (concatMap ppAnnotErr [(x,y) | (x,y,_) <- es])
+  show (Ann ts es _ _) =  "\n\n" 
+                      ++ (concatMap ppAnnotTyp $ M.toList ts)
+                      ++ (concatMap ppAnnotErr [(x,y) | (x,y,_) <- es])
 
 ppAnnotTyp :: (PrintfArg t, PrintfType t1) => (Loc, (t, String)) -> t1
 ppAnnotTyp (L (l, c), (x, s))     = printf "%s\n%d\n%d\n%d\n%s\n\n\n" x l c (length $ lines s) s

src/Language/Haskell/Liquid/UX/ACSS.hs

@@ -5,7 +5,6 @@
 {-# LANGUAGE TypeSynonymInstances       #-}
 {-# LANGUAGE FlexibleInstances          #-}
 
-{- LIQUID "--diffcheck" @-}
 
 ---------------------------------------------------------------------------
 -- | This module contains the code that uses the inferred types to generate
@@ -14,10 +13,8 @@
 -- 3. JSON files for the web-demo etc.
 ---------------------------------------------------------------------------
 
-
 module Language.Haskell.Liquid.UX.Annotate
-  ( specAnchor
-  , mkOutput
+  ( mkOutput
   , annotate
   , tokeniseWithLoc
   , annErrors
@@ -67,7 +64,7 @@ import           Language.Haskell.Liquid.Types.RefType
 import           Language.Haskell.Liquid.UX.Errors            ()
 import           Language.Haskell.Liquid.UX.Tidy
 import           Language.Haskell.Liquid.Types                hiding (Located(..), Def(..))
-import           Language.Haskell.Liquid.Types.Specifications
+-- import           Language.Haskell.Liquid.Types.Specifications
 
 
 -- | @output@ creates the pretty printed output
@@ -230,7 +227,12 @@ cssHTML css = unlines
 --   annotations.
 
 mkAnnMap :: Config -> ErrorResult -> AnnInfo Doc -> ACSS.AnnMap
-mkAnnMap cfg res ann     = ACSS.Ann (mkAnnMapTyp cfg ann) (mkAnnMapErr res) (mkStatus res)
+mkAnnMap cfg res ann     = ACSS.Ann 
+                             { ACSS.types   = mkAnnMapTyp cfg ann 
+                             , ACSS.errors  = mkAnnMapErr res 
+                             , ACSS.status  = mkStatus res 
+                             , ACSS.sptypes = mkAnnMapBinders cfg ann
+                             }
 
 mkStatus :: FixResult t -> ACSS.Status
 mkStatus (Safe)          = ACSS.Safe
@@ -255,8 +257,7 @@ cinfoErr e = case pos e of
 mkAnnMapTyp :: Config -> AnnInfo Doc -> M.HashMap Loc (String, String)
 mkAnnMapTyp cfg z = M.fromList $ map (first srcSpanStartLoc) $ mkAnnMapBinders cfg z
 
-mkAnnMapBinders :: Config
-                -> AnnInfo Doc -> [(SrcLoc.RealSrcSpan, (String, String))]
+mkAnnMapBinders :: Config -> AnnInfo Doc -> [(SrcLoc.RealSrcSpan, (String, String))]
 mkAnnMapBinders cfg (AI m)
   = map (second bindStr . head . sortWith (srcSpanEndCol . fst))
   $ groupWith (lineCol . fst) locBinds
@@ -423,6 +424,9 @@ instance ToJSON AnnErrors where
                                    , "message" .= toJSON (dropErrorLoc s)
                                    ]
 
+
+
+
 dropErrorLoc :: String -> String
 dropErrorLoc msg
   | null msg' = msg
@@ -436,11 +440,18 @@ instance (Show k, ToJSON a) => ToJSON (Assoc k a) where
       tshow        = T.pack . show
 
 instance ToJSON ACSS.AnnMap where
-  toJSON a = object [ "types"  .= toJSON (annTypes    a)
-                    , "errors" .= toJSON (annErrors   a)
-                    , "status" .= toJSON (ACSS.status a)
+  toJSON a = object [ "types"   .= toJSON (annTypes     a)
+                    , "errors"  .= toJSON (annErrors    a)
+                    , "status"  .= toJSON (ACSS.status  a)
+                    , "sptypes" .= (toJ <$> ACSS.sptypes a) 
                     ]
-
+    where 
+      toJ (sp, (x,t)) = object [ "start" .= toJSON (srcSpanStartLoc sp) 
+                               , "stop"  .= toJSON (srcSpanEndLoc   sp) 
+                               , "ident" .= toJSON x 
+                               , "ann"  .= toJSON t 
+                               ] 
+                      
 annErrors :: ACSS.AnnMap -> AnnErrors
 annErrors = AnnErrors . ACSS.errors