|
| 1 | +{-# LANGUAGE FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, LambdaCase, MultiParamTypeClasses, NamedFieldPuns, RecordWildCards, TypeApplications, TypeOperators, UndecidableInstances #-} |
| 2 | +module Analysis.Concrete |
| 3 | +( Concrete(..) |
| 4 | +, concrete |
| 5 | +, concreteAnalysis |
| 6 | +, heapGraph |
| 7 | +, heapValueGraph |
| 8 | +, heapAddressGraph |
| 9 | +, addressStyle |
| 10 | +) where |
| 11 | + |
| 12 | +import qualified Algebra.Graph as G |
| 13 | +import qualified Algebra.Graph.Export.Dot as G |
| 14 | +import Analysis.Eval |
| 15 | +import Control.Applicative (Alternative (..)) |
| 16 | +import Control.Effect |
| 17 | +import Control.Effect.Fail |
| 18 | +import Control.Effect.Fresh |
| 19 | +import Control.Effect.NonDet |
| 20 | +import Control.Effect.Reader hiding (Local) |
| 21 | +import Control.Effect.State |
| 22 | +import Control.Monad ((<=<), guard) |
| 23 | +import qualified Data.Core as Core |
| 24 | +import Data.File |
| 25 | +import Data.Function (fix) |
| 26 | +import qualified Data.IntMap as IntMap |
| 27 | +import qualified Data.IntSet as IntSet |
| 28 | +import Data.Loc |
| 29 | +import qualified Data.Map as Map |
| 30 | +import Data.Monoid (Alt(..)) |
| 31 | +import Data.Name |
| 32 | +import Prelude hiding (fail) |
| 33 | + |
| 34 | +type Precise = Int |
| 35 | +type Env = Map.Map Name Precise |
| 36 | + |
| 37 | +newtype FrameId = FrameId { unFrameId :: Precise } |
| 38 | + deriving (Eq, Ord, Show) |
| 39 | + |
| 40 | +data Concrete |
| 41 | + = Closure Loc Name Core.Core Precise |
| 42 | + | Unit |
| 43 | + | Bool Bool |
| 44 | + | String String |
| 45 | + | Obj Frame |
| 46 | + deriving (Eq, Ord, Show) |
| 47 | + |
| 48 | +objectFrame :: Concrete -> Maybe Frame |
| 49 | +objectFrame (Obj frame) = Just frame |
| 50 | +objectFrame _ = Nothing |
| 51 | + |
| 52 | +data Frame = Frame |
| 53 | + { frameEdges :: [(Core.Edge, Precise)] |
| 54 | + , frameSlots :: Env |
| 55 | + } |
| 56 | + deriving (Eq, Ord, Show) |
| 57 | + |
| 58 | +type Heap = IntMap.IntMap Concrete |
| 59 | + |
| 60 | + |
| 61 | +-- | Concrete evaluation of a term to a value. |
| 62 | +-- |
| 63 | +-- >>> snd (concrete [File (Loc "bool" emptySpan) (Core.Bool True)]) |
| 64 | +-- [Right (Bool True)] |
| 65 | +concrete :: [File Core.Core] -> (Heap, [File (Either (Loc, String) Concrete)]) |
| 66 | +concrete |
| 67 | + = run |
| 68 | + . runFresh |
| 69 | + . runHeap |
| 70 | + . traverse runFile |
| 71 | + |
| 72 | +runFile :: ( Carrier sig m |
| 73 | + , Effect sig |
| 74 | + , Member Fresh sig |
| 75 | + , Member (Reader FrameId) sig |
| 76 | + , Member (State Heap) sig |
| 77 | + ) |
| 78 | + => File Core.Core |
| 79 | + -> m (File (Either (Loc, String) Concrete)) |
| 80 | +runFile file = traverse run file |
| 81 | + where run = runReader (fileLoc file) |
| 82 | + . runFailWithLoc |
| 83 | + . fix (eval concreteAnalysis) |
| 84 | + |
| 85 | +concreteAnalysis :: ( Carrier sig m |
| 86 | + , Member Fresh sig |
| 87 | + , Member (Reader Loc) sig |
| 88 | + , Member (Reader FrameId) sig |
| 89 | + , Member (State Heap) sig |
| 90 | + , MonadFail m |
| 91 | + ) |
| 92 | + => Analysis Precise Concrete m |
| 93 | +concreteAnalysis = Analysis{..} |
| 94 | + where alloc _ = fresh |
| 95 | + bind name addr = modifyCurrentFrame (updateFrameSlots (Map.insert name addr)) |
| 96 | + lookupEnv n = do |
| 97 | + FrameId frameAddr <- ask |
| 98 | + val <- deref frameAddr |
| 99 | + heap <- get |
| 100 | + pure (val >>= lookupConcrete heap n) |
| 101 | + deref = gets . IntMap.lookup |
| 102 | + assign addr value = modify (IntMap.insert addr value) |
| 103 | + abstract _ name body = do |
| 104 | + loc <- ask |
| 105 | + FrameId parentAddr <- ask |
| 106 | + pure (Closure loc name body parentAddr) |
| 107 | + apply eval (Closure loc name body parentAddr) a = do |
| 108 | + frameAddr <- fresh |
| 109 | + assign frameAddr (Obj (Frame [(Core.Lexical, parentAddr)] mempty)) |
| 110 | + local (const loc) . (frameAddr ...) $ do |
| 111 | + addr <- alloc name |
| 112 | + assign addr a |
| 113 | + bind name addr |
| 114 | + eval body |
| 115 | + apply _ f _ = fail $ "Cannot coerce " <> show f <> " to function" |
| 116 | + unit = pure Unit |
| 117 | + bool b = pure (Bool b) |
| 118 | + asBool (Bool b) = pure b |
| 119 | + asBool v = fail $ "Cannot coerce " <> show v <> " to Bool" |
| 120 | + string s = pure (String s) |
| 121 | + asString (String s) = pure s |
| 122 | + asString v = fail $ "Cannot coerce " <> show v <> " to String" |
| 123 | + -- FIXME: differential inheritance (reference fields instead of copying) |
| 124 | + -- FIXME: copy non-lexical parents deeply? |
| 125 | + frame = do |
| 126 | + lexical <- asks unFrameId |
| 127 | + pure (Obj (Frame [(Core.Lexical, lexical)] mempty)) |
| 128 | + -- FIXME: throw an error |
| 129 | + -- FIXME: support dynamic imports |
| 130 | + edge e addr = modifyCurrentFrame (\ (Frame ps fs) -> Frame ((e, addr) : ps) fs) |
| 131 | + addr ... m = local (const (FrameId addr)) m |
| 132 | + |
| 133 | + updateFrameSlots f frame = frame { frameSlots = f (frameSlots frame) } |
| 134 | + |
| 135 | + modifyCurrentFrame f = do |
| 136 | + addr <- asks unFrameId |
| 137 | + Just (Obj frame) <- deref addr |
| 138 | + assign addr (Obj (f frame)) |
| 139 | + |
| 140 | + |
| 141 | +lookupConcrete :: Heap -> Name -> Concrete -> Maybe Precise |
| 142 | +lookupConcrete heap name = run . evalState IntSet.empty . runNonDet . inConcrete |
| 143 | + where -- look up the name in a concrete value |
| 144 | + inConcrete = inFrame <=< maybeA . objectFrame |
| 145 | + -- look up the name in a specific 'Frame', with slots taking precedence over parents |
| 146 | + inFrame (Frame ps fs) = maybeA (Map.lookup name fs) <|> getAlt (foldMap (Alt . inAddress . snd) ps) |
| 147 | + -- look up the name in the value an address points to, if we haven’t already visited it |
| 148 | + inAddress addr = do |
| 149 | + visited <- get |
| 150 | + guard (addr `IntSet.notMember` visited) |
| 151 | + -- FIXME: throw an error if we can’t deref @addr@ |
| 152 | + val <- maybeA (IntMap.lookup addr heap) |
| 153 | + modify (IntSet.insert addr) |
| 154 | + inConcrete val |
| 155 | + maybeA = maybe empty pure |
| 156 | + |
| 157 | + |
| 158 | +runHeap :: (Carrier sig m, Member Fresh sig) => ReaderC FrameId (StateC Heap m) a -> m (Heap, a) |
| 159 | +runHeap m = do |
| 160 | + addr <- fresh |
| 161 | + runState (IntMap.singleton addr (Obj (Frame [] mempty))) (runReader (FrameId addr) m) |
| 162 | + |
| 163 | + |
| 164 | +-- | 'heapGraph', 'heapValueGraph', and 'heapAddressGraph' allow us to conveniently export SVGs of the heap: |
| 165 | +-- |
| 166 | +-- > λ let (heap, res) = concrete [ruby] |
| 167 | +-- > λ writeFile "/Users/rob/Desktop/heap.dot" (export (addressStyle heap) (heapAddressGraph heap)) |
| 168 | +-- > λ :!dot -Tsvg < ~/Desktop/heap.dot > ~/Desktop/heap.svg |
| 169 | +heapGraph :: (Precise -> Concrete -> a) -> (Either Core.Edge Name -> Precise -> G.Graph a) -> Heap -> G.Graph a |
| 170 | +heapGraph vertex edge h = foldr (uncurry graph) G.empty (IntMap.toList h) |
| 171 | + where graph k v rest = (G.vertex (vertex k v) `G.connect` outgoing v) `G.overlay` rest |
| 172 | + outgoing = \case |
| 173 | + Unit -> G.empty |
| 174 | + Bool _ -> G.empty |
| 175 | + String _ -> G.empty |
| 176 | + Closure _ _ _ parentAddr -> edge (Left Core.Lexical) parentAddr |
| 177 | + Obj frame -> fromFrame frame |
| 178 | + fromFrame (Frame es ss) = foldr (G.overlay . uncurry (edge . Left)) (foldr (G.overlay . uncurry (edge . Right)) G.empty (Map.toList ss)) es |
| 179 | + |
| 180 | +heapValueGraph :: Heap -> G.Graph Concrete |
| 181 | +heapValueGraph h = heapGraph (const id) (const fromAddr) h |
| 182 | + where fromAddr addr = maybe G.empty G.vertex (IntMap.lookup addr h) |
| 183 | + |
| 184 | +heapAddressGraph :: Heap -> G.Graph (EdgeType, Precise) |
| 185 | +heapAddressGraph = heapGraph (\ addr v -> (Value v, addr)) (fmap G.vertex . (,) . either Edge Slot) |
| 186 | + |
| 187 | +addressStyle :: Heap -> G.Style (EdgeType, Precise) String |
| 188 | +addressStyle heap = (G.defaultStyle vertex) { G.edgeAttributes } |
| 189 | + where vertex (_, addr) = maybe (show addr <> " = ?") (((show addr <> " = ") <>) . fromConcrete) (IntMap.lookup addr heap) |
| 190 | + edgeAttributes _ (Slot name, _) = ["label" G.:= fromName name] |
| 191 | + edgeAttributes _ (Edge Core.Import, _) = ["color" G.:= "blue"] |
| 192 | + edgeAttributes _ (Edge Core.Lexical, _) = ["color" G.:= "green"] |
| 193 | + edgeAttributes _ _ = [] |
| 194 | + fromConcrete = \case |
| 195 | + Unit -> "()" |
| 196 | + Bool b -> show b |
| 197 | + String s -> show s |
| 198 | + Closure (Loc p (Span s e)) n _ _ -> "\\\\ " <> fromName n <> " [" <> p <> ":" <> showPos s <> "-" <> showPos e <> "]" |
| 199 | + Obj _ -> "{}" |
| 200 | + showPos (Pos l c) = show l <> ":" <> show c |
| 201 | + fromName (User s) = s |
| 202 | + fromName (Gen sym) = fromGensym sym |
| 203 | + fromName (Path p) = show p |
| 204 | + fromGensym (Root s) = s |
| 205 | + fromGensym (ss :/ (s, i)) = fromGensym ss <> "." <> s <> show i |
| 206 | + |
| 207 | +data EdgeType |
| 208 | + = Edge Core.Edge |
| 209 | + | Slot Name |
| 210 | + | Value Concrete |
| 211 | + deriving (Eq, Ord, Show) |
0 commit comments